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

allow using opgen for reading longs from places besides the DP long "register"

Browse source
This commit is contained in:
Jeremy Penner 2021-08-16 19:05:53 -04:00
parent 315fd794de
commit 6eec75d5f2
3 changed files with 54 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
ssc/iigs/toolbox.fnl
View file

@ -17,17 +17,17 @@
block [:block]
iloc-resultptr (do (assert (= arg-count expected-arg-count) (.. name " expected " expected-arg-count " args, got " (fv [...])))
(when resultptr
(lume.push block (ssc:push nil (ssc:expr-word resultptr)))
(lume.push block (ssc:push nil resultptr :word))
(length ssc.locals)))]
(for [_ 1 (match return-type :void 0 :word 1 :long 2 _ return-type)]
(lume.push block (ssc:push)))
(lume.push block (ssc:push nil nil :register)))
(each [_ push (ipairs (ssc:push-arguments (ssc:parse-parameters args) (lume.slice [...] 1 (length args))))]
(lume.push block push))
(lume.push block [:ldx cmd] [:jsr :0xe10000])
(ssc:was-dropped (length args))
(when error-handler
(lume.push block [:bcc :-no-error-]
(ssc:push :error) (ssc:expr-poly error-handler) (ssc:drop :error)
(ssc:push :error nil :register) (ssc:expr-poly error-handler) (ssc:drop :error)
:-no-error-))
(match return-type
:void nil

63
ssc/init.fnl
View file

@ -69,12 +69,17 @@
(rts))))))
(fn Ssc.push [self name expr ?etype]
(local etype (or ?etype :word))
(table.insert self.locals {: name :type etype})
(match etype
:word [:block (or expr [:flatten]) [:pha]]
:long [:block (or expr [:flatten]) [:lda self.LONG_HI] [:pha] [:lda self.LONG_LO] [:pha]]
_ (error (.. "Unknown stack type " (tostring etype)))))
(let [opgen (if (= ?etype :register) {:lo #[:flatten]}
(self:expr-opgen expr ?etype))
etype (if (= ?etype :register) :word
?etype ?etype
opgen.hi :long
:word)
c-setup (when opgen.setup (opgen.setup))
c-lo [(opgen.lo :lda) [:pha]]
c-hi (when opgen.hi [(opgen.hi :lda) [:pha]])]
(table.insert self.locals {: name :type etype})
(lume.concat [:block c-setup] c-hi c-lo)))
(fn Ssc.remove-local [self ?name]
(let [loc (. self.locals (length self.locals))]
@ -234,7 +239,7 @@
expr))))
(values c-body etype-body))
:let (fn [self bindings ...]
(let [compiled-bindings (icollect [_ symbol expr (pairoff bindings)] (self:push symbol (self:expr-poly expr)))
(let [compiled-bindings (icollect [_ symbol expr (pairoff bindings)] (self:push symbol expr))
(compiled-body etype) (self:expr-poly [:do ...])
compiled-cleanup (icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))]
@ -284,8 +289,12 @@
: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]])
:loword (lambda [self long]
(let [{: lo : setup} (self:expr-opgen long :long)]
(lume.concat [:block] [(when setup (setup))] (lo :lda))))
:hiword (lambda [self long]
(let [{: hi : setup} (self:expr-opgen long :long)]
(lume.concat [:block] [(when setup (setup))] (hi :lda))))
:ref (lambda [self label] [:lda #(loword ($1:lookup-addr label))])
:far-ref (lambda [self label] (values [:block [:lda #(loword ($1:lookup-addr label))] [:sta self.LONG_LO]
[:lda #(hiword ($1:lookup-addr label))] [:sta self.LONG_HI]] :long))
@ -299,13 +308,13 @@
(self:expr-word value) [:sta [[self.ADDR_LO]]]]
_ (error (.. "Unknown reference type " reftype)))
:void)))
:long! (lambda [self ref value] [:block (self:push nil (self:expr-word ref) :word)
:long! (lambda [self ref value] [:block (self:push nil ref :word)
(self:expr-long value) [:ldy 0] [:lda self.LONG_LO] [:sta [1 :s] :y] [:iny] [:iny] [:lda self.LONG_HI] [:sta [1 :s] :y]
(self:drop)])
:word-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
[:block (self:push nil c-ref :word) [:ldy 0] [:lda [1 :s] :y] (self:drop)]
[:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] (self:drop)]
(= etype :long)
[:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]]))
@ -313,7 +322,7 @@
:long-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
(values [:block (self:push nil c-ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
(values [:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
:long)
(= etype :long)
@ -322,16 +331,13 @@
:set! (lambda [self lhs value]
(if (and (= (type lhs) :string) (. self.setters lhs))
(self:compile-function-call (. self.setters lhs) [value])
(let [(c-value etype) (self:expr-poly value)
(let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
c-setup (when setup (setup))
{: lo : hi} (assert (self:opgen-lhs lhs) (.. (fv lhs) " not valid as a target of set!"))
c-lo (match etype
:word (lo :sta)
:long [:block [:lda self.LONG_LO] (lo :sta)])
c-hi (when hi (match etype
:word [:block [:lda 0] (hi :sta)]
:long [:block [:lda self.LONG_HI] (hi :sta)]))
c-lo [:flatten (val-lo :lda) (lo :sta)]
c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
block [:block]]
(lume.push block c-value c-lo c-hi)
(lume.push block c-setup c-lo c-hi)
block)))
})
@ -402,10 +408,22 @@
(fn Ssc.push-opgen [self expr]
(or (self:opgen expr)
(let [c (self:push nil (self:expr-poly expr))
(let [c (self:push nil expr)
iloc (length self.locals)]
(lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
(fn Ssc.expr-opgen [self expr ?expected-etype]
(var opgen (self:opgen expr))
(when (not opgen)
(let [(c-expr etype) (self:expr-poly expr)]
(set opgen (match etype
:word {:setup #c-expr :lo #[:flatten]}
:long {:setup #c-expr :lo #[$1 self.LONG_LO] :hi #[$1 self.LONG_HI]}))))
(when (and (= ?expected-etype :long) (= opgen.hi nil)) (set opgen.hi #[$1 0]))
(when (and ?expected-etype (= opgen nil)) (error (.. "Expected " ?expected-etype ", got void")))
(when (and (= ?expected-etype :word) opgen.hi) (error (.. "Expected word, got long")))
opgen)
(fn Ssc.parse-parameters [self params]
(icollect [_ param (ipairs params)] (match param
[:long pname] {:name pname :type :long}
@ -414,8 +432,7 @@
(fn Ssc.push-arguments [self paramdefs args]
(icollect [iarg arg (ipairs args)]
(let [atype (. paramdefs iarg :type)
c-arg (: self (.. :expr- atype) arg)
c-push (self:push nil c-arg atype)]
c-push (self:push nil arg atype)]
c-push)))
(fn Ssc.compile-function-call [self f args]

11
ssc/notes.txt Normal file
View file

@ -0,0 +1,11 @@
full compilation to expr-opgen TODO:
- gen-condition could potentially use it for lhs which is on the stack / in a global
- word! and long! are a mess right now
- I don't think word-at and long-at could use it
- Could custom forms compile to opgens?? What would this look like?
* see far-ref - it's really a constant, there's no reason to stuff the result into the temporary register just to push it onto the stack
* if you call expr-poly / expr-word / expr-long, then put it into the register
* but if you call expr-opgen, just return it! (opgen.setup) returns the appropriate code if needed
* toolbox calls could actually benefit from this! function calls, not so much
* currently expr-opgen is assumed to not have a cleanup step - this could complicate things