SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Fix conditionals! And optimize the hell out of them!

Browse source
This commit is contained in:
Jeremy Penner 2021-08-11 22:34:07 -04:00
parent 1eea56bb5b
commit 8eef9e49b8
2 changed files with 92 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

25
neutgs/init.fnl
View file

@ -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
View file

@ -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)