458 lines
24 KiB
Fennel
458 lines
24 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.
|
|
|
|
; * 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
|
|
|
|
; TODO:
|
|
; * implement "getters" (subroutine that runs when referenced by name without an explicit call)
|
|
|
|
(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} util)
|
|
|
|
(set Ssc.LONG_LO :d0x00)
|
|
(set Ssc.LONG_HI :d0x02)
|
|
(set Ssc.ADDR_LO :d0x04)
|
|
(set Ssc.ADDR_HI :d0x06)
|
|
(set Ssc.TRUE 0xffff)
|
|
(set Ssc.FALSE 0)
|
|
|
|
(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 {})
|
|
(if opts.boot (self:compile (table.unpack opts.boot))
|
|
(self:compile (!
|
|
(start-symbol boot)
|
|
(org [(or opts.boot-org 0)])
|
|
(asm
|
|
boot
|
|
(clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
|
|
(jsr main)
|
|
(sec) (xce) ;re-enter emulation mode
|
|
(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)))))
|
|
|
|
(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] (> (length self.locals) 0))
|
|
|
|
(fn countiter [minmax ?max]
|
|
(let [min (if ?max minmax 1)
|
|
max (or ?max minmax)]
|
|
(fn [_ iprev]
|
|
(let [i (if iprev (+ iprev 1) min)]
|
|
(when (<= i max) i)))))
|
|
|
|
(fn pairoff [l]
|
|
(fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
|
|
(when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
|
|
|
|
; 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)]
|
|
(pp cond)
|
|
(if cmp
|
|
(let [[lhs rhs] args
|
|
ropgen (self:push-opgen rhs)
|
|
pre (when ropgen.setup (ropgen.setup))
|
|
(left etype) (self:expr-poly lhs)
|
|
truebranch (if ropgen.cleanup (.. :-if-true-cleanup- depth) truelabel)
|
|
falsebranch (if ropgen.cleanup (.. :-if-false-cleanup- depth) falselabel)
|
|
hibranch (when (= etype :long)
|
|
[[:lda self.LONG_HI] (ropgen.hi :cmp) (cmp.hibranch truebranch falsebranch) [:lda self.LONG_LO]])
|
|
lobranch [(ropgen.lo :cmp) (cmp.lobranch falsebranch)]
|
|
cleanup (when ropgen.cleanup (ropgen.cleanup))
|
|
post (if cleanup [truebranch cleanup [:bra truelabel] falsebranch cleanup [:bra 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 ...] self.TRUE self.FALSE]))
|
|
|
|
(set Ssc.forms
|
|
{:asm (fn [self ...] (if (self:defining?) [:block ...] (self.org:append ...)))
|
|
: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))
|
|
: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 (self:expr-poly 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 ...]
|
|
(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])
|
|
(tset self.functions name {:arity (length args) :args arglocals :org self.org :type etype})
|
|
(assert (= (length self.locals) (+ (length args) 1))
|
|
(.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
|
|
(set self.locals []))
|
|
:if (lambda [self test iftrue ?iffalse]
|
|
(let [(c-true truetype) (self:expr-poly iftrue)
|
|
(c-false falsetype) (when ?iffalse (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]
|
|
_ (pp block)
|
|
cl-false (if ?iffalse [[: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 [:bra :-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 [:clc] (self:simple-accumulator :adc 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] [:block (self:expr-long long) [:lda self.LONG_LO]])
|
|
:hiword (lambda [self long] [:block (self:expr-long long) [:lda self.LONG_HI]])
|
|
: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))
|
|
; TODO: maybe handle a few different addressing modes here? re-use if the value is already on the stack?
|
|
; TODO: automatically handle far-ref
|
|
: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 (self:expr-word 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)]
|
|
|
|
(= 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 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)]
|
|
: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]
|
|
(let [(c-value etype) (self:expr-poly value)
|
|
{: lo : hi} (self:opgen-lhs lhs)
|
|
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)]))
|
|
block [:block]]
|
|
(lume.push block c-value c-lo c-hi)
|
|
block))
|
|
})
|
|
|
|
(fn Ssc.local-offset [self name-or-index]
|
|
(var offset nil)
|
|
(var stacklen 0)
|
|
(for [i 1 (length self.locals)]
|
|
(let [loc (. self.locals i)
|
|
size (match loc.type :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.set-long [self loexpr hiexpr]
|
|
[:block loexpr [:sta self.LONG_LO] hiexpr [:sta self.LONG_HI]])
|
|
(fn Ssc.set-long-local [self loc]
|
|
(self:set-long [:lda (self:local-offset loc) :s] [:lda (+ (self:local-offset loc) 2) :s]))
|
|
|
|
(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) (self:opgen-lhs expr)))
|
|
|
|
(fn Ssc.push-opgen [self expr]
|
|
(or (self:opgen expr)
|
|
(let [c (self:push nil (self:expr-poly expr))
|
|
iloc (length self.locals)]
|
|
(lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
|
|
|
|
(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-arg (: self (.. :expr- atype) arg)
|
|
c-push (self:push nil c-arg atype)]
|
|
c-push)))
|
|
|
|
(fn Ssc.expr-poly [self expr]
|
|
(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))
|
|
; TODO: Global scope
|
|
(where [func & args] (= (?. self.functions func :arity) (length args)))
|
|
(let [f (. self.functions func)
|
|
pre (self:push-arguments f.args args)
|
|
post (icollect [_ (countiter (length args))] (self:drop))]
|
|
(values (lume.concat [:block] pre [[:jsr func]] post) f.type))
|
|
(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 " (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
|