SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

32-bit support!! toolbox is currently broken but the main compiler seems to have stabilized

Browse source
This commit is contained in:
Jeremy Penner 2021-08-08 21:58:49 -04:00
parent cd4bf59b41
commit b63573cc89
3 changed files with 207 additions and 100 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
neutgs/init.fnl
View file

@ -1,20 +1,11 @@
(local Ssc (require :ssc))
(import-macros {:sss ! : compile} :ssc.macros)
(local ssc (Ssc))
(set ssc.prg.start-symbol :boot)
(local ssc (Ssc {:boot-org 0xc00}))
(compile ssc
(require :ssc.iigs.toolbox)
(org 0xc00)
(asm
boot
(clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
(jsr main)
(sec) (xce) ;re-enter emulation mode
(rts)
pascalhex (db 5) hexbuf (bytes " "))
(asm pascalhex (db 5) hexbuf (bytes " "))
(fn printnum (num)
(HexIt num (& hexbuf))
(WriteString 0 (& pascalhex)))
@ -32,6 +23,7 @@
(IMShutDown)
(MMShutDown userid)
(TLShutDown)))
)
(ssc:assemble)

8
ssc/iigs/toolbox.fnl
View file

@ -13,14 +13,14 @@
expected-arg-count (if error-handler (+ expected-arg-count 1) expected-arg-count)
block [:block]]
(assert (= arg-count expected-arg-count))
(when resultptr (lume.push block (ssc:compile-expr resultptr) (ssc:push)))
(when resultptr (lume.push block (ssc:expr-word resultptr) (ssc:push)))
(for [_ 1 return-words] (lume.push block (ssc:push)))
(for [i 1 param-words] (lume.push block (ssc:compile-expr (select i ...)) (ssc:push)))
(for [i 1 param-words] (lume.push block (ssc:expr-word (select i ...)) (ssc:push)))
(lume.push block [:ldx cmd] [:jsr :0xe10000])
(ssc:was-dropped param-words)
(when error-handler
(lume.push block [:bcc :-no-error-]
(ssc:push :error) (ssc:compile-expr error-handler) (ssc:drop)
(ssc:push :error) (ssc:expr-word error-handler) (ssc:drop)
:-no-error-))
(if (= return-words 1) (lume.push block (ssc:pop))
@ -31,7 +31,7 @@
(when (< i return-words) (lume.push block [:iny] [:iny]))))
(lume.push block (ssc:drop))))
block))]
(ssc:compile-expr [:form name call])))])
(ssc:expr-poly [:form name call])))])
; todo: some kind of type system, or wrappers for 32-bit pointers, god

285
ssc/init.fnl
View file

@ -5,7 +5,8 @@
; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
; the assembly directly.
; * All values are 16-bit integers, like Forth or BCPL.
; * Values default to 16-bit integers, like Forth or BCPL.
; * 32-bit integers are also handled, and the "last value" is stored in a separate "register" in the direct page.
; * 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.
@ -36,32 +37,58 @@
; * implement loops
; * 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))
(set Ssc.LONG_LO :d0x00)
(set Ssc.LONG_HI :d0x02)
(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.modules {})
(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]
(table.insert self.locals {: name :type etype})
(match etype
:word [:block expr [:pha]]
:long [:block expr [:lda self.LONG_HI] [:pha] [:lda self.LONG_LO] [:pha]]))
(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.push [self ?local]
(table.insert self.locals (or ?local [:tmp]))
[:pha])
(fn Ssc.drop [self ?local]
(match (. self.locals (length self.locals))
[:tmp] (when (not= ?local nil) (error (.. "Internal stack error: expected " ?local ", got temporary")))
loc (when (not= ?local loc) (error (.. "Internal stack error: expected " (or ?local "temporary") " temporary, got " loc))))
(tset self.locals (length self.locals) nil)
[:ply])
(fn Ssc.pop [self ?local]
(self:drop ?local)
[:pla])
(fn Ssc.was-dropped [self localcount]
(set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
@ -78,11 +105,24 @@
(fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
(when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
; Comparison theory:
; word x word constant -> word
; long x long constant -> word
; word x word -> word
; long x long -> word
; Any combination of word and long gets promoted to long (we have to compare both words anyway).
; this should hold for beq and bpl, but not bmi and bne
; optimized cases:
; reg + immediate
; reg + stack? nope, reg + stack isn't really possible when the operator isn't commutative
; stack + reg
(fn boolop [self left right branch]
(let [compiled-left (self:compile-expr left)
(let [compiled-left (self:expr-word left)
push-left (when (not= (type right) :number) (self:push))
compiled-compare (if (not push-left) [:cmp right]
[:block push-left (self:compile-expr right) [:cmp 1 :s]])
[:block push-left (self:expr-word right) [:cmp 1 :s]])
drop-left (when push-left (self:drop))]
[:block
compiled-left
@ -95,105 +135,180 @@
:-finished-
drop-left]))
; 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-addressible 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)))
(set Ssc.forms
{:asm (fn [self ...]
(if (self:defining?) [:block ...]
(self.org:append ...)))
:org (lambda [self org] (set self.org (self.prg:org org)))
:do (fn [self ...] (lume.concat [:block] (icollect [i (countiter (select :# ...))] (self:compile-expr (select i ...)))))
: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))))
: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 ...]
(lume.concat [:block]
(icollect [_ symbol expr (pairoff bindings)]
[:block (self:compile-expr expr) (self:push symbol)])
[(self:compile-expr [:do ...])]
(icollect [i-half (countiter (/ (length bindings) 2))]
(self:drop (. bindings (- (length bindings) (* i-half 2) -1))))))
(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 (icollect [_ arg (ipairs args)] (match arg
[:long aname] {:name aname :type :long}
aname {:name aname :type :word})))
(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-test (self:expr-word test)
(c-true truetype) (self:expr-poly iftrue)
(c-false falsetype) (when ?iffalse (self:expr-poly ?iffalse))
etype (if (and falsetype (not= truetype falsetype)) :void truetype)]
(values (lume.concat [:block
c-test
[:cmp 0] [:beq (if ?iffalse :-elseblock- :-finished-)]
c-true]
(when ?iffalse [
[:bra :-finished-]
:-elseblock- c-false])
[:-finished-]) etype)))
:+ (lambda [self first ...]
(local block [:block (self:compile-expr first)])
(for [i 1 (select :# ...)]
(let [val (select i ...)]
(table.insert block
(match val
1 [:inc] 2 [:block [:inc] [:inc]]
-1 [:dec] -2 [:block [:dec] [:dec]]
(where val (= (type val) :number)) [:block [:clc] [:adc val]]
(where sym (= (type sym) :string) (self:local-offset sym)) [:block [:clc] [:adc (self:local-offset sym) :s]]
_ [:block (self:push) (self:compile-expr val) [:clc] [:adc 1 :s] (self:drop)]))))
block)
(self:accumulation-op
(fn [etype {: lo : hi : const}]
(match etype
:word (if (= const 1) [:inc] (= const 2) [:block [:inc] [:inc]]
(= const -1) [:dec] (= const -2) [:block [:dec] [:dec]]
[:block [:clc] (lo :adc)])
:long [:block [:clc] (lo :lda) [:adc self.LONG_LO] [:sta self.LONG_LO]
(if hi (hi :lda) [:lda 0]) [:adc self.LONG_HI] [:sta self.LONG_HI]]))
first ...))
:- (lambda [self first ...]
(let [block [:block (self:compile-expr first)]
nargs (select :# ...)]
(if (= nargs 0) (table.insert block [:block [:eor 0xffff] [:inc]]) ; negate with two's complement
(for [i 1 nargs]
(let [val (select i ...)]
(table.insert block
(match val
1 [:dec] 2 [:block [:dec] [:dec]]
-1 [:inc] -2 [:block [:inc] [:inc]]
(where val (= (type val) :number)) [:block [:sec] [:sbc val]]
(where sym (= (type sym) :string) (self:local-offset sym)) [:block [:sec] [:sbc (self:local-offset sym) :s]]
_ [:block (self:push) (self:compile-expr val) [:sec] [:sbc 1 :s] (self:drop)])))))
block))
(self:accumulation-op
(fn [etype {: lo : hi : const}]
(match etype
:word (if (= const 1) [:dec] (= const 2) [:block [:dec] [:dec]]
(= const -1) [:inc] (= const -2) [:block [:inc] [:inc]]
[:block [:sec] (lo :sbc)])
:long [:block [:sec] (lo :lda) [:sbc self.LONG_LO] [:sta self.LONG_LO]
(if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))))
:= (lambda [self lhs rhs] (boolop self lhs rhs :beq))
:not= (lambda [self lhs rhs] (boolop self lhs rhs :bne))
:< (lambda [self lhs rhs] (boolop self lhs rhs :bmi))
:> (lambda [self lhs rhs] (boolop self rhs lhs :bmi))
:>= (lambda [self lhs rhs] (boolop self lhs rhs :bpl))
:<= (lambda [self lhs rhs] (boolop self rhs lhs :bpl))
:not (lambda [self bool] (self:compile-expr [:if bool 0 0xffff]))
:if (lambda [self test iftrue ?iffalse]
(lume.concat
[:block
(self:compile-expr test)
[:cmp 0]
[:beq :-elseblock-]
(self:compile-expr iftrue)]
(when ?iffalse [[:bra :-finished-]])
[:-elseblock-]
(when ?iffalse [(self:compile-expr ?iffalse)])
[:-finished-]))
:fn (lambda [self name args ...]
(assert (not (self:defining?)))
(set self.locals (lume.concat args [[:tmp]]))
(tset self.functions name {:arity (length args) : args :org self.org})
; todo: maybe handle mutually recursive functions? (compile-expr only has access to currently-defined functions)
(self.org:append name (self:compile-expr (lume.concat [:do ...] [[:asm [:rts]]])))
(assert (= (length self.locals) (+ (length args) 1)))
(set self.locals []))
: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))))
:& (lambda [self label] [:lda #($1:lookup-addr label)])
:not (lambda [self bool] (self:expr-poly [:if bool 0 0xffff]))
:or (lambda [self lhs rhs] (self:expr-poly [:if lhs 0xffff [:if rhs 0xffff 0]]))
:and (lambda [self lhs rhs] (self:expr-poly [:if lhs [:if rhs 0xffff 0] 0]))
:& (lambda [self label] [:lda #($1:lookup-addr label)])
})
(fn Ssc.local-offset [self symbol]
(fn Ssc.local-offset [self name-or-index]
(var offset nil)
(for [i 1 (length self.locals)]
(when (= (. self.locals i) symbol)
(when (or (= i name-or-index) (= (. self.locals i :name) name-or-index))
(set offset (+ 1 (* 2 (- (length self.locals) i))))))
offset)
(fn Ssc.compile-expr [self expr]
(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))
(fn Ssc.addressible-const [self const]
{:lo #[$1 (bit.band const 0xffff)] :hi (let [hi (bit.rshift (bit.band 0xffff0000) 16)] (if (or (= hi 0) (= hi 0xffff)) nil #[$1 hi])) : const})
(fn Ssc.addressible-loc [self loc]
{:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2)])})
(fn Ssc.addressible [self expr]
(match (type expr)
:number (self:addressible-const expr)
(where :string (self:local-offset expr)) (self:addressible-loc expr)))
(fn Ssc.push-addressible [self expr]
(or (self:addressible expr)
(let [c (self:push nil (self:expr-poly expr))
iloc (length (self.locals))]
(lume.merge (self:addressible-loc iloc) {:setup #c :cleanup #(self:drop)}))))
(fn Ssc.expr-poly [self expr]
(match expr
(where num (= (type num) :number)) [:lda num]
(where loc (= (type loc) :string) (self:local-offset loc)) [:lda (self:local-offset loc) :s]
(where lit (?. (self:addressible lit) :hi)) (let [{: lo : hi} (self:addressible lit)]
(values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
(where lit (?. (self:addressible lit) :lo)) (let [{: lo} (self:addressible lit)] (values (lo :lda) :word))
; TODO: Global scope
(where [func & args] (= (?. self.functions func :arity) (length args)))
(let [pre (icollect [_ arg (ipairs args)] [:block (self:compile-expr arg) (self:push)])
(let [f (. self.functions func)
pre (icollect [iarg arg (ipairs args)]
(let [atype (. f.args iarg :type)
c-arg (: self (.. :expr- atype) arg)
c-push (self:push nil c-arg atype)]
c-push))
post (icollect [_ (countiter (length args))] (self:drop))]
(lume.concat [:block] pre [[:jsr func]] post))
(print (fv pre) (fv post) (fv args))
(values (lume.concat [:block] pre [[:jsr func]] post) f.type))
(where [form & args] (. self.forms form))
((. self.forms form) self (table.unpack args))
nil [:block]
(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 " etype " in " (fv expr) " - wanted long or word"))))
(fn Ssc.compile [self ...]
(for [i 1 (select :# ...)]
(self:compile-expr (select i ...)))
(self:expr-poly (select i ...)))
self)
(fn Ssc.assemble [self]