From b63573cc8977e0590e83290993f781f5cf3b89be Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Sun, 8 Aug 2021 21:58:49 -0400 Subject: [PATCH] 32-bit support!! toolbox is currently broken but the main compiler seems to have stabilized --- neutgs/init.fnl | 14 +-- ssc/iigs/toolbox.fnl | 8 +- ssc/init.fnl | 285 ++++++++++++++++++++++++++++++------------- 3 files changed, 207 insertions(+), 100 deletions(-) diff --git a/neutgs/init.fnl b/neutgs/init.fnl index 5d6e1e3..5d41110 100644 --- a/neutgs/init.fnl +++ b/neutgs/init.fnl @@ -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) diff --git a/ssc/iigs/toolbox.fnl b/ssc/iigs/toolbox.fnl index 1f21d7c..cf22cbb 100644 --- a/ssc/iigs/toolbox.fnl +++ b/ssc/iigs/toolbox.fnl @@ -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 diff --git a/ssc/init.fnl b/ssc/init.fnl index 18434a3..2819e62 100644 --- a/ssc/init.fnl +++ b/ssc/init.fnl @@ -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]