honeylisp/ssc/init.fnl
Jeremy Penner 12481e9257 non-working attempt to lazily expand macros using lua proxy objects
Unfortunately there is no way to override # in luajit, so I can't make
a truly transparent proxy. Unclear if I could get away with a weird
half-object, but it doesn't seem to be working.
2021-10-22 20:44:24 -04:00

552 lines
29 KiB
Fennel

; 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.
; * Expressions have 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
(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 : condlist : prototype : proxy} util)
(fn Ssc.new [self ?opts]
(local opts (or ?opts {}))
(set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
(set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
(set self.functions (prototype (or (?. opts.parent :functions) {})))
(set self.locals [])
(set self.addr-to-callsite {})
(set self.modules (prototype (or (?. opts.parent :modules) {})))
(set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
(set self.macros (prototype (or opts.macros (?. opts.parent :macros) self.__index.macros)))
(set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
(set self.setters (prototype (or (?. opts.parent :setters) {})))
(set self.dp-vars (or (?. opts.parent :dp-vars) 0))
(set self.gensym-count (or (?. opts.parent :gensym-count) 0))
(set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
(set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
(set self.ADDR_LO (or (?. opts.parent :ADDR_LO) (self:alloc-dp-var)))
(set self.ADDR_HI (or (?. opts.parent :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.gensym [self ?prefix]
(let [sym (.. "<gensym " self.gensym-count (if ?prefix (.. " " ?prefix ">") ">"))]
(set self.gensym-count (+ self.gensym-count 1))
sym))
(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.define-fn [self name locals f]
(assert (not (self:defining?)) "Can't nest function definitions")
(set self.defining-fn name)
(set self.locals (when locals (lume.clone locals)))
(set self.callsites {})
(let [result (f)]
(set self.defining-fn nil)
(set self.callsites {})
(assert (or (and (= locals nil) (= self.locals nil))
(= (length self.locals) (length locals)))
(.. "Left locals on stack?? Expected " (fv locals) " got " (fv self.locals)))
(set self.locals [])
result))
(fn Ssc.defining? [self] (not= self.defining-fn nil))
; 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-generic [self name args body post-body returnaddr-type call-instruction]
(let [arglocals (self:parse-parameters args)]
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :returnaddr true}])
#(let [(c-function etype) (self:expr-poly body)]
(self.org:append name c-function (table.unpack post-body))
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
(fn Ssc.asm-localify [self block]
(icollect [_ inst (ipairs block)]
(match inst
[op [:ref sym] & rest] [op sym (table.unpack rest)]
(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)))
(fn string? [v] (= (type v) :string))
(fn xxxx-at [v] ; matches byte-at, word-at, long-at
(when (string? v)
(let [(i-at i-done) (v:find :-at)]
(when (and i-at (= i-done (length v))) (v:sub 1 (- i-at 1))))))
(fn Ssc.compile-read-at [self ref etype] ; opgen catches the trivial cases; we have to compile ref to get a pointer
(let [opgen (self:expr-opgen ref)
pre (when opgen.setup (opgen.setup))
load (if opgen.hi [:lda [[self.ADDR_LO]] :y] [:lda [self.ADDR_LO] :y])
load (if (= etype :byte) [:block [:rep 0x30] load [:sep 0x30] [:and 0xff]] load)]
(values (condlist :block pre (opgen.lo :lda) [:sta self.ADDR_LO]
(when opgen.hi [:block (opgen.hi :lda) [:sta self.ADDR_HI]])
[:ldy 0] load
(when (= etype :long) [:block [:sta self.LONG_LO] [:ldy 2] load [:sta self.LONG_HI]]))
(if (= etype :byte) :word etype))))
(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 (self:asm-localify [: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))
:define (lambda [self name val] (tset self.constants name val))
:macro (lambda [self name func] (tset self.macros name func))
:macrobarrier (lambda [self formname] (tset self.macrobarriers formname true))
: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.constants name [(.. etype :-at) [:ref [:quote name]]])
(self.org:append [:hot-preserve name
(match etype
:byte [:db ?const]
:word [:dw ?const]
:long [:dl ?const]
_ (error (.. "Unrecognized type " (fv etype))))]))
:buffer (lambda [self name bytes-or-size]
(self.org:append [:hot-preserve name [:bytes (match (type bytes-or-size)
:string bytes-or-size
:number (string.rep "\x00" bytes-or-size))]]))
: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 ...)))
:far-fn (lambda [self name args ...] (tset self.functions name (self:compile-far-function name args ...)))
:predef-fn (lambda [self name args etype ?far]
(tset self.functions name {:arity (length args) :args (self:parse-parameters args) :org self.org :type etype : name :call-instruction (if (= ?far :far) :jsl :jsr)}))
: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)))
: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)))
:forever (lambda [self ...] [:block :-loop-top- (self:expr-poly [:do ...]) [:brl :-loop-top-]])
:+ (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]])
: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] (self:compile-read-at ref :byte))
:word-at (lambda [self ref] (self:compile-read-at ref :word))
:long-at (lambda [self ref] (self:compile-read-at ref :long))
:set! (lambda [self lhs value]
(if (and (= (type lhs) :string) (. self.setters lhs))
(self:compile-function-call (. self.setters lhs) [value])
(self:opgen-lhs lhs)
(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} (self:opgen-lhs lhs)
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)
(values block :void))
(and (= (type lhs) :table) (xxxx-at (. lhs 1)))
(let [ropgen (self:push-opgen value)
pre1 (when ropgen.setup (ropgen.setup))
lopgen (self:expr-opgen (. lhs 2))
pre2 (when lopgen.setup (lopgen.setup))
etype (xxxx-at (. lhs 1))
store (if lopgen.hi [:sta [[self.ADDR_LO]] :y] [:sta [self.ADDR_LO] :y])
store (if (= etype :byte) [:block [:rep 0x30] store [:sep 0x30]] store)]
(values (condlist :block pre1 pre2 (lopgen.lo :lda) [:sta self.ADDR_LO]
(when lopgen.hi [:block (lopgen.hi :lda) [:sta self.ADDR_HI]])
(ropgen.lo :lda) [:ldy 0] store
(when (= etype :long) [:block (if ropgen.hi (ropgen.hi :lda) [:lda 0]) [:ldy 2] store])
(when ropgen.cleanup (ropgen.cleanup)))
:void))
(error (.. (fv lhs) " not valid as a target of set!"))))
})
(set Ssc.macros
{:getter (lambda [self name ...] (let [getter-name (.. "<get " name ">")]
[:do [:fn getter-name [] ...]
[:define name [getter-name]]]))
:when (lambda [self test ...] [:if test [:do ...]])
:byte! (lambda [self ref value] [:set! [:byte-at ref] value])
:word! (lambda [self ref value] [:set! [:word-at ref] value])
:long! (lambda [self ref value] [:set! [:long-at ref] value])
:data (lambda [self bytes]
(print "data" bytes (self:defining?))
(if (self:defining?) (let [name (self:gensym)] (self:expr-poly [:buffer name bytes]) name)
bytes))
:pstr (lambda [self str] [:data (.. (string.char (length str)) str)]) ; pascal-style
:cstr (lambda [self str] [:data (.. str "\x00")]) ; c-style
})
(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]
(if (= etype :byte) {:lo #[:block [:sep 0x30] [$1 name] [:rep 0x30] (when (= $1 :lda) [:and 0xff])]}
{:lo #[$1 name] :hi (when (= etype :long) #[$1 {:abs #(+ ($1:lookup-addr name) 2)}])}))
(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-lhs [self expr]
(match [(type expr) expr]
(where [:string _] (self:local-offset expr)) (self:opgen-local expr)
(where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
(where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
(fn Ssc.opgen [self expr]
(if (= (type expr) :number) (self:opgen-const 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)
locals (lume.clone self.locals)
callid (or (. self.callsites f.name) 0)
_ (tset self.callsites f.name (+ callid 1))
funcname self.defining-fn
callsite-sym (.. "<callsite " funcname " " f.name ":" callid ">")
capture-addr (fn [addr] (tset self.addr-to-callsite (- addr 1) {: callsite-sym : locals : funcname :calling f.name}))
post (icollect [_ (countiter (length args))] (self:drop))]
(values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] 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-index [self expr index] (self:expr-expand (. expr index)))
(fn Ssc.expr-expand [self expr]
(let [mt (or (getmetatable expr) {})
expanded (match expr
[:quote rawsymbol] rawsymbol
(where c (. self.constants c)) (self:expr-expand (. self.constants c))
(where [m & args] (. self.macros m)) (self:expr-expand ((. self.macros m) self (table.unpack args)))
_ expr)]
(if (= (type expanded) :table) (proxy expanded #(self:expr-expand $1))
expanded)))
(fn Ssc.expr-poly [self expr]
(self:enter-expr expr)
(let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
expr (self:expr-expand expr)
(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 [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)
(set self.prg.source self)
self.prg)
(fn Ssc.read-hotswap [self machine prg-new]
(local {: hotswap-stacks} (require :ssc.hotswap))
(hotswap-stacks machine self prg-new.source))
Ssc