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

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

ssc/init.fnl

@@ -69,12 +69,17 @@
         (rts))))))
 
 (fn Ssc.push [self name expr ?etype]
-  (local etype (or ?etype :word))
+  (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})
-  (match etype
+    (lume.concat [:block c-setup] c-hi c-lo)))
-    :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)))))
 
 (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]])
+    :loword (lambda [self long]
-    :hiword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_HI]])
+              (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
+                    c-lo [:flatten (val-lo :lda) (lo :sta)]
-                           :word (lo :sta)
+                    c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :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)]))
                     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 arg atype)]
-          c-push (self:push nil c-arg atype)]
       c-push)))
 
 (fn Ssc.compile-function-call [self f args]

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