diff --git a/ssc/iigs/toolbox.fnl b/ssc/iigs/toolbox.fnl index 386fd92..45fdf21 100644 --- a/ssc/iigs/toolbox.fnl +++ b/ssc/iigs/toolbox.fnl @@ -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 diff --git a/ssc/init.fnl b/ssc/init.fnl index 36a87a6..c9e1b35 100644 --- a/ssc/init.fnl +++ b/ssc/init.fnl @@ -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] diff --git a/ssc/notes.txt b/ssc/notes.txt new file mode 100644 index 0000000..86dff9b --- /dev/null +++ b/ssc/notes.txt @@ -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