honeylisp/ssc/init.fnl

; ssc: the sufficiently simple compiler

; The goal of ssc is to allow simple prefix expressions to be compiled into 65816 code that
; would run at least as fast or faster than the equivalent threaded Forth code. Complex
; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
; the assembly directly.

; * 3 data types: word (2 bytes), long (4 bytes), void (0 bytes).
; * Expressions return their results in different places depending on type - word values are stored in the A register,
;   long values are stored in the direct page at LONG_LO / LONG_HI.
; * Data and return addresses are mixed on one stack, unlike Forth.
; * Function calls take a fixed number of arguments, and return 0 or 1 results. The compiler enforces arity checking.
; * To call a function taking arguments [arg1 arg2 arg3], all 3 arguments should be pushed to the stack before calling.
;   When the function takes control, the stack should look like this:
;     arg1 arg2 arg3 return-address
; * The caller is responsible for removing all arguments from the stack once the function returns.
; * The caller is responsible for preserving the A, X and Y registers, if this is desirable.
; * If the function returns a value, it is stored in the A/LONG register, like any expression.
; * If a function returns no result, it is not obliged to preserve the A/LONG register.
; * Multitasking is achieved by overlapping the D and S registers on the same 256-byte page of memory.
;   Yielding to a new task involves saving the S register, setting the D register to the new task's page,
;   then setting the S register to the saved value in the old task.
; * Useful task-local "registers" are kept at the beginning of the page, and the stack grows down from the end of the page.
;   * DP register list:
;     * LONG (32-bit "register")
;     * Last suspended value of S
;     * Mailbox
;     * Pointer to next task

; Compiler notes:
; Expressions are of the form [:function arg1 arg2 arg3]
; args are either strings (symbols) or numbers

(import-macros {:sss ! : compile} :ssc.macros)
(local Object (require :core.object))
(local lume (require :lib.lume))
(local Ssc (Object:extend))
(local Prg (require :asm.asm))
(local util (require :lib.util))
(local {: loword : hiword : pairoff : countiter} util)

(fn Ssc.new [self ?opts]
  (local opts (or ?opts {}))
  (set self.prg (or opts.prg (Prg.new nil :65816)))
  (set self.forms (lume.clone (or opts.forms self.__index.forms)))
  (set self.functions {})
  (set self.locals [])
  (set self.modules {})
  (set self.globals {})
  (set self.constants {:true 0xffff :false 0})
  (set self.getters {})
  (set self.setters {})
  (set self.dp-vars 0)
  (set self.LONG_LO (self:alloc-dp-var))
  (set self.LONG_HI (self:alloc-dp-var))
  (set self.ADDR_LO (self:alloc-dp-var))
  (set self.ADDR_HI (self:alloc-dp-var)))

(fn Ssc.alloc-dp-var [self]
  (let [addr (.. :d self.dp-vars)]
    (set self.dp-vars (+ self.dp-vars 2))
    addr))

(fn Ssc.push [self name expr ?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-hi (when opgen.hi [(opgen.hi :lda) [:pha]])
        loc {: name :type (if c-hi :word :placeholder)}
        _ (table.insert self.locals loc) ; if we push a high word onto the stack it shifts stack offsets
        c-lo [(opgen.lo :lda) [:pha]]]
    (set loc.type etype)
    (lume.concat [:block c-setup] c-hi c-lo)))

(fn Ssc.remove-local [self ?name]
  (let [loc (. self.locals (length self.locals))]
    (when (not= loc.name ?name) (error (.. "Internal stack error: expected " (or ?name "temporary") ", got " (or loc.name "temporary"))))
    (tset self.locals (length self.locals) nil)
    loc))

(fn Ssc.drop [self ?name]
  (match (. (self:remove-local ?name) :type)
    :word [:ply]
    :long [:block [:ply] [:ply]]))

(fn Ssc.pop [self ?name]
  (let [{:type etype} (self:remove-local ?name)]
    (values (match etype
              :word [:pla]
              :long [:block [:pla] [:sta self.LONG_LO] [:pla] [:sta self.LONG_HI]])
            etype)))

(fn Ssc.was-dropped [self localcount]
  (set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))

(fn Ssc.defining? [self] (or (= self.locals nil) (> (length self.locals) 0)))

; 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)
; 2. load left into accumulator
; 3. apply until done
(fn Ssc.accumulation-op [self op first ...]
  (var etype (self:type-expr first))
  (for [i 1 (select :# ...)] (when (= (self:type-expr (select i ...)) :long) (set etype :long)))
  (let [args (icollect [_ val (ipairs [...])] (self:push-opgen val))
        setup (icollect [_ {: setup} (ipairs args)] (when setup (setup)))
        acc (: self (.. :expr- etype) first)
        operations (icollect [i addr (ipairs args)] (op etype addr i))
        cleanup (icollect [_ {: cleanup} (ipairs args)] (when cleanup (cleanup)))]
    (values (lume.concat [:block] setup [acc] operations cleanup) etype)))

(fn Ssc.simple-accumulator [self op etype {: lo : hi} ?defaulthi]
  (match etype
    :word (lo op)
    :long [:block [:lda self.LONG_LO] (lo op) [:sta self.LONG_LO]
                  [:lda self.LONG_HI] (if hi (hi op) [op (or ?defaulthi 0)]) [:sta self.LONG_HI]]))

; 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)]
    (if cmp
        (let [[lhs rhs] args
              ropgen (self:push-opgen rhs)
              pre (when ropgen.setup (ropgen.setup))
              lopgen (self:expr-opgen lhs)
              left (when lopgen.setup (lopgen.setup))
              truebranch (.. :-if-true-cleanup- depth)
              falsebranch (.. :-if-false-cleanup- depth)
              hibranch (when lopgen.hi
                         [(lopgen.hi :lda) (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch)])
              lobranch [(lopgen.lo :lda) (ropgen.lo :cmp) (cmp.lobranch falsebranch)]
              cleanup (if ropgen.cleanup (ropgen.cleanup) [:flatten])
              post (if cleanup [truebranch cleanup [:brl truelabel] falsebranch cleanup [:brl 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 ...] true false]))

(fn Ssc.compile-function [self name args ...]
  (assert (not (self:defining?)) "Can't nest function definitions")
  (local arglocals (self:parse-parameters args))
  (set self.locals (lume.concat arglocals [{:type :word :comment :returnaddr}]))
  ; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
  (local (c-function etype) (self:expr-poly [:do ...]))
  (self.org:append name c-function [:rts])
  (assert (= (length self.locals) (+ (length args) 1))
          (.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
  (set self.locals [])
  {:arity (length args) :args arglocals :org self.org :type etype : name})

(fn Ssc.asm-localify [self block]
  (icollect [_ inst (ipairs block)]
    (match inst
      (where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
        [op (+ (self:local-offset loc) (or ?off 0)) :s]
      (where [op [loc ?off] :y]  (and (= (type loc) :string) (self:local-offset loc)))
        [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
      [:block] (self:asm-localify inst)
      _        inst)))

(set Ssc.forms
  {:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
   :asm-long (fn [self ...] (values [:block ...] :long))
   :org (lambda [self org] (set self.org (self.prg:org org)))
   :start-symbol (lambda [self symbol] (set self.prg.start-symbol symbol))
   :form (lambda [self name func] (tset self.forms name func))
   :const (lambda [self name val] (tset self.constants name val))
   :getter (lambda [self name ...] (tset self.getters name (self:compile-function (.. :-get- name) [] ...)))
   :setter (lambda [self name arg ...]
     (assert (= (length arg) 1))
     (tset self.setters name (self:compile-function (.. :-set- name) arg ...)))
   :require (lambda [self name ...]
              (when (= (. self.modules name) nil)
                (let [mod (util.reload name)
                      func (if (= (type mod) :function) mod mod.module)]
                  (tset self.modules name mod)
                  (func self ...))))
   :global (lambda [self etype name ?const]
             (tset self.globals name {:type etype : name})
             (self.org:append name
               (match etype
                 :word [:dw ?const]
                 :long [:dl ?const]
                 _ (error (.. "Unrecognized type " (fv etype))))))
   :do (fn [self ...]
         (var etype-body :void)
         (local c-body (lume.concat [:block] (icollect [i (countiter (select :# ...))]
                                               (let [(expr etype) (self:expr-poly (select i ...))]
                                                 (set etype-body etype)
                                                 expr))))
         (values c-body etype-body))
   :let (fn [self bindings ...]
          (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))))]
            (values (lume.concat [:block] compiled-bindings [compiled-body] compiled-cleanup) etype)))
   :fn (lambda [self name args ...] (tset self.functions name (self:compile-function name args ...)))
   :if (lambda [self test iftrue ?else ...]
         (let [(c-true truetype) (self:expr-poly iftrue)
               iffalse (if (> (select :# ...) 0) [:if ?else ...] ?else)
               (c-false falsetype) (when (not= iffalse nil) (self:expr-poly iffalse))
               etype (if (not= truetype falsetype) :void truetype)
               block [:block (self:gen-condition test :-if-true- :-if-false-) :-if-true- c-true]
               cl-false (if (not= iffalse nil) [[:bra :-if-done-] :-if-false- c-false :-if-done-]
                                               [:-if-false-])]
           (values (lume.concat block cl-false) etype)))
   :when (lambda [self test ...] (self:expr-poly [:if test [:do ...]]))
   :while (lambda [self test ...]
            (let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
                  c-body (self:expr-poly [:do ...])]
              (values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
   :+ (lambda [self first ...]
        (self:accumulation-op
          (fn [etype opgen]
            (if (and (= etype :word) opgen.const (>= opgen.const -2) (<= opgen.const 2))
                (match opgen.const  1 [:inc]  2 [:block [:inc] [:inc]]
                                   -1 [:dec] -2 [:block [:dec] [:dec]])
              [:block [:clc] (self:simple-accumulator :adc etype opgen)]))
          first ...))
   :- (lambda [self first ...]
        (if (= (select :# ...) 0)
            (match (self:type-expr first) :word [:block (self:expr-word first) [:eor 0xffff] [:inc]] ; negate with two's complement
                                          :long (self:expr-poly [:- 0 first])) ; just subtract from 0
          (self:accumulation-op
            (fn [etype opgen]
              (if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
                  (match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
                                      1 [:dec]  2 [:block [:dec] [:dec]])
                [:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
            first ...)))
    :| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
    :& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
    :^ (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :eor $...) first ...))
    := (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]
              (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))
    :byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
    ; TODO: maybe handle a few different addressing modes here? re-use if the value is already on the stack?
    ; TODO: automatically handle far-ref
    :byte! (lambda [self ref value]
             (let [(c-addr reftype) (self:expr-poly ref)]
               (values (match reftype
                         :word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sep 0x30] [:sta [self.ADDR_LO] :y] [:rep 0x30]]
                         :long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
                                       (self:expr-word value) [:sep 0x30] [:sta [[self.ADDR_LO]]] [:rep 0x30]]
                         _ (error (.. "Unknown reference type " reftype)))
                       :void)))
    :word! (lambda [self ref value]
             (let [(c-addr reftype) (self:expr-poly ref)]
               (values (match reftype
                         :word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sta [self.ADDR_LO] :y]]
                         :long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
                                       (self:expr-word value) [:sta [[self.ADDR_LO]]]]
                         _ (error (.. "Unknown reference type " reftype)))
                       :void)))
    :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)])
    :long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
    :byte-at (lambda [self ref]
               (local (c-ref etype) (self:expr-poly ref))
               (if (= etype :word)
                   [:block (self:push nil ref :word) [:ldy 0] [:sep 0x30] [:lda [1 :s] :y] [:rep 0x30] [:and 0xff] (self:drop)]

                   (= etype :long)
                   [:block c-ref [:ldy 0] [:sep 0x30] [:lda [[self.LONG_LO]] :y] [:rep 0x30] [:and 0xff]]))
    :word-at (lambda [self ref]
               (local (c-ref etype) (self:expr-poly ref))
               (if (= etype :word)
                   [: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]]))

    :long-at (lambda [self ref]
               (local (c-ref etype) (self:expr-poly ref))
               (if (= etype :word)
                   (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)
                   (values [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] :y] [:sta self.LONG_HI] [:stx self.LONG_LO]]
                           :long)))
    :set! (lambda [self lhs value]
            (if (and (= (type lhs) :string) (. self.setters lhs))
                (self:compile-function-call (. self.setters lhs) [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 [: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-setup c-lo c-hi)
                block)))
  })

(fn Ssc.local-offset [self name-or-index]
  (var offset nil)
  (var stacklen 0)
  (when self.locals
    (for [i 1 (length self.locals)]
      (let [loc (. self.locals i)
            size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
        (set stacklen (+ stacklen size))
        (when (or (= i name-or-index) (= loc.name name-or-index))
          (set offset stacklen)))))
  (when offset (+ (- stacklen offset) 1)))

(fn Ssc.local-type [self name-or-index]
  (var etype nil)
  (for [i 1 (length self.locals)]
    (when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
      (set etype (. self.locals i :type))))
  etype)

(fn Ssc.type-expr [self expr] (let [(_ etype) (self:expr-poly expr)] etype))

; opgen - a small structure that allows for reading a value with many different addressing modes
; :lo and :hi keys are functions that, when called with an opcode, returns that opcode with the appropriate argument to work on
; either the low or high word. If :hi does not exist in the structure, then the value represented by the opgen is only word-sized.
; :setup and :cleanup keys are used by push-opgen to handle generation of the necessary stack manipulation instructions.
; opgen-const makes the constant available in the :const key so it can be checked and potentially optimized further (+1 -> inc)
(fn Ssc.opgen-const [self const]
  {:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band const 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})

(fn Ssc.opgen-local [self loc]
  {:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})

(fn Ssc.opgen-symbol [self name etype]
  {:lo #[$1 name] :hi (when (= etype :long) #[:block [:ldy 2] [$1 name :y]])}) ; this is stupid - the assembler should be able to calculate addr + 2

(fn Ssc.opgen-global [self name] (self:opgen-symbol name (. self.globals name :type)))

(fn Ssc.opgen-ref-loc [self name etype]
  (when (= (self:local-type name) :word) ; long pointer deref is not possible directly from the stack; have to eval and move to LONG register
    {:lo #[:block [:ldy 0] [$1 [(self:local-offset name) :s] :y]]
     :hi (when (= etype :long) #[:block [:ldy 2] [$1 [(self:local-offset name) :s] :y]])}))

(fn Ssc.opgen-ref-global [self name etype]
  (match (. self.globals name :type)
    :word {:lo #[:block [:ldy 0] [$1 [name] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [name] :y]])}
    :long {:lo #[:block [:ldy 0] [$1 [[name]] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [[name]] :y]])}))

(fn string? [v] (= (type v) :string))
(fn Ssc.opgen-lhs [self expr]
  (match [(type expr) expr]
    [:string _] (if (self:local-offset expr) (self:opgen-local expr)
                    (. self.globals expr)    (self:opgen-global expr))
    (where [_ [:word-at [:ref name]]] (string? name)) (self:opgen-symbol name :word)
    (where [_ [:long-at [:ref name]]] (string? name)) (self:opgen-symbol name :long)
    (where [_ [:word-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :word)
                                                   (. self.globals name)    (self:opgen-ref-global name :word))
    (where [_ [:long-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :long)
                                                   (. self.globals name)    (self:opgen-ref-global name :long))))

(fn Ssc.opgen [self expr]
  (if (= (type expr) :number) (self:opgen-const expr)
      (= expr true) (self:opgen-const self.constants.true)
      (= expr false) (self:opgen-const self.constants.false)
      (and (= (type expr) :string) (. self.constants expr)) (self:opgen (. self.constants expr))
    (self:opgen-lhs expr)))

(fn Ssc.push-opgen [self expr]
  (or (self:opgen 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}
                                    pname         {:name pname :type :word})))

(fn Ssc.push-arguments [self paramdefs args]
  (icollect [iarg arg (ipairs args)]
    (let [atype (. paramdefs iarg :type)
          c-push (self:push nil arg atype)]
      c-push)))

(fn Ssc.compile-function-call [self f args]
  (let [pre (self:push-arguments f.args args)
        post (icollect [_ (countiter (length args))] (self:drop))]
    (values (lume.concat [:block] pre [[:jsr f.name]] post) f.type)))

(fn Ssc.enter-expr [self expr]
  (let [m (getmetatable expr)]
    (when (and m m.filename) (set self.expr-metadata m))))

(fn Ssc.expr-poly [self expr]
  (self:enter-expr expr)
  (let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
        (success c-expr etype)
        (pcall #(match expr
                  (where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
                    (values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
                  (where lit (?. (self:opgen lit) :lo)) (let [{: lo} (self:opgen lit)] (values (lo :lda) :word))
                  (where getter (= (type getter) :string) (. self.getters getter))
                    (self:compile-function-call (. self.getters getter) [])
                  (where [func & args] (= (?. self.functions func :arity) (length args)))
                    (self:compile-function-call (. self.functions func) args)
                  (where [form & args] (. self.forms form))
                    (let [f (. self.forms form)
                          (cexpr etype) (f self (table.unpack args))]
                      (values cexpr (or etype :word)))
                  nil (values [:block] :void)
                  _ (error (.. "Unrecognized expression"))))]
    (if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
                    (values c-expr etype))
      (let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))

(fn Ssc.expr-word [self expr]
  (let [(c etype) (self:expr-poly expr)]
    (when (not= etype :word) (error (.. "Unexpected long or void in " (fv expr) " - please wrap in explicit truncation form")))
    c))

(fn Ssc.expr-long [self expr]
  (let [(c etype) (self:expr-poly expr)]
    (match etype
      :long c
      :word [:block c [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]]
      _ (error (.. "Unexpected type " (fv etype) " in " (fv expr) " - wanted long or word")))))

(fn Ssc.compile [self ...]
  (for [i 1 (select :# ...)]
    (self:expr-poly (select i ...)))
  self)

(fn Ssc.assemble [self]
  (self.prg:assemble)
  self.prg)

Ssc