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

Better pointer handling, implement set!

Browse source
This commit is contained in:
Jeremy Penner 2021-08-10 00:33:54 -04:00
parent 29de142c4a
commit 8a211365e4
3 changed files with 94 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
neutgs/init.fnl
View file

@ -6,6 +6,7 @@
(require :ssc.iigs.toolbox)
(asm pascalhex (db 5) hexbuf (bytes " "))
(fn printnum (num)
(long! (ref hexbuf) (HexIt num))
(WriteString (far-ref pascalhex)))
@ -17,7 +18,12 @@
(IMStartUp)
(TextStartUp)
(printnum (add 1 2))
(let (x 1)
(printnum x)
(set! x (+ x 1))
(printnum x)
(set! (long-at (ref hexbuf)) 0x6b636548)
(WriteString (far-ref pascalhex)))
(TextShutDown)
(IMShutDown)

2
ssc/iigs/toolbox.fnl
View file

@ -40,8 +40,6 @@
(values block (if (= (type return-type) :string) return-type :void))))]
(ssc:expr-poly [:form name call])))])
; todo: some kind of type system, or wrappers for 32-bit pointers, god
; toolbox locator
(def-toolbox 0x0201 TLStartUp () void)
(def-toolbox 0x0301 TLShutDown () void)

114
ssc/init.fnl
View file

@ -5,8 +5,9 @@
; optimizations are a non-goal; if you want to tune the generated code, go ahead and write
; the assembly directly.
; * 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.
; * 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.
@ -14,15 +15,14 @@
; 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 register.
; * If a function returns no result, it is not obliged to preserve the A register.
; * 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:
; * bank-local address (16 bits)
; * long address (24 bits)
; * LONG (32-bit "register")
; * Last suspended value of S
; * Mailbox
; * Pointer to next task
@ -32,8 +32,8 @@
; args are either strings (symbols) or numbers
; TODO:
; * implement read / write (pointers)
; * implement write (locals)
; * implement global definitions
; * fix comparisons
; * implement loops
; * implement "getters" (subroutine that runs when referenced by name without an explicit call)
@ -55,6 +55,7 @@
(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)
@ -146,7 +147,7 @@
(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))
(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))
@ -154,9 +155,8 @@
(values (lume.concat [:block] setup [acc] operations cleanup) etype)))
(set Ssc.forms
{:asm (fn [self ...]
(if (self:defining?) [:block ...]
(self.org:append ...)))
{: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))
@ -222,7 +222,8 @@
(= 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]]))))
(if hi (hi :lda) [:lda 0]) [:sbc self.LONG_HI] [:sta self.LONG_HI]]))
first ...))
:= (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))
@ -243,7 +244,35 @@
: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)])
:deref (lambda [self ref] [:block (self:push nil (self:expr-word ref) :word) [:lda [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)
[: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)]
(= etype :long)
[:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] [:sta self.LONG_HI] [:stx self.LONG_LO]]))
: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]]
(pp c-value)
(lume.push block c-value c-lo c-hi)
block))
})
(fn Ssc.local-offset [self name-or-index]
@ -271,21 +300,52 @@
(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)])})
; 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.addressible [self expr]
(match (type expr)
:number (self:addressible-const expr)
(where :string (self:local-offset expr)) (self:addressible-loc expr)))
(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.push-addressible [self expr]
(or (self:addressible expr)
(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:addressible-loc iloc) {:setup #c :cleanup #(self:drop)}))))
(lume.merge (self:opgen-local iloc) {:setup #c :cleanup #(self:drop)}))))
(fn Ssc.parse-parameters [self params]
(icollect [_ param (ipairs params)] (match param
@ -301,9 +361,9 @@
(fn Ssc.expr-poly [self expr]
(match expr
(where lit (?. (self:addressible lit) :hi)) (let [{: lo : hi} (self:addressible lit)]
(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:addressible lit) :lo)) (let [{: lo} (self:addressible lit)] (values (lo :lda) :word))
(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)