From b6db098a70af5a09efbaba6a14daa44004af63e7 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Fri, 30 Jul 2021 21:57:38 -0400 Subject: [PATCH] Factor out 6502 into its own module, generalize asm, complete 65816?? --- asm/6502.fnl | 125 ++++++++++++++++++++++++++++++++++++++++++ asm/65816.fnl | 65 +++++++++++++++++----- asm/asm.fnl | 147 +++++++------------------------------------------- main.lua | 1 + 4 files changed, 198 insertions(+), 140 deletions(-) create mode 100644 asm/6502.fnl diff --git a/asm/6502.fnl b/asm/6502.fnl new file mode 100644 index 0000000..49d33f5 --- /dev/null +++ b/asm/6502.fnl @@ -0,0 +1,125 @@ +(local {: int8-to-bytes : int16-to-bytes} (require "lib.util")) + +(local opcodes {}) + +; op mode arg +; single-byte ops +(let [ops + {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8 + :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8 + :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}] + (each [opcode byte (pairs ops)] + (tset opcodes opcode (fn [mode] (if mode nil byte))))) +(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil))) + +; branch ops +(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}] + (each [opcode byte (pairs ops)] + (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil))))) +(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil))) + +; aaabbbcc ops +(fn aaabbbcc [aaa cc modemap] + (local base (bit.bor cc (bit.lshift aaa 5))) + (fn [mode] + (local bbb (. modemap mode)) + (if bbb (bit.bor base (bit.lshift bbb 2)) nil))) + +(fn indexed-modes [...] + (let [modemap {}] + (each [index mode (pairs [...])] + (tset modemap mode (- index 1))) + modemap)) + +(fn without-modes [modemap ...] + (let [newmodemap (lume.clone modemap)] + (each [_ mode (pairs [...])] + (tset newmodemap mode nil)) + newmodemap)) + +(fn only-modes [modemap ...] + (let [newmodemap {}] + (each [_ mode (pairs [...])] + (tset newmodemap mode (. modemap mode))) + newmodemap)) + +; cc=1 ops +(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x) + ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}] + (each [opcode aaa (pairs ops)] + (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes)) + (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm))))) +; cc=2 ops +(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)] + (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})] + (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes)) + (each [opcode aaa (pairs {:dec 6 :inc 7})] + (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a)))))) +(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y))) +(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y))) + +; cc=0 ops +(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)] + (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs))) + (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x))) + (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes)) + (each [opcode aaa (pairs {:cpy 6 :cpx 7})] + (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs))))) +(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil))) + +(fn parse-mode-arg [op] + (match op + [_ :a] [:a nil] + ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm] + ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch + [_ addr :x] [:addr-x addr] + [_ [addr] :y] [:zp*-y addr] + [_ addr :y] [:addr-y addr] + [_ [addr :x]] [:zp-x* addr] + ([_ addr] ? (= (type addr) "string")) [:addr addr] + [_ [addr]] [:abs* addr] + [_] [nil nil] + _ (error (.. "Unrecognized syntax" (fv op))))) + +(local op-pdat {}) + +(fn is-zp? [env name] + (match (env:lookup-org name) + org (< org 0x100))) + +(fn op-pdat.patch [op env] + (when (and op.mode (= (op.mode:sub 1 4) :addr)) + (let [zp-mode (.. :zp (op.mode:sub 5)) + abs-mode (.. :abs (op.mode:sub 5)) + is-zp (and ((. opcodes op.opcode) zp-mode) (is-zp? env op.arg))] + (set op.mode (if is-zp zp-mode abs-mode))))) + +(fn op-pdat.size [{: mode}] + (if + (or (= mode nil) (= mode :a)) 1 + (= (mode:sub 1 3) :abs) 3 + 2)) + +(fn op-pdat.bytes [op env] + (local bytegen (. opcodes op.opcode)) +; (pp op) + (if bytegen + (let [opbyte (bytegen op.mode) + argbytes + (if + (and (= op.mode :imm) (= (type op.arg) "function")) + (int8-to-bytes (op.arg env)) + + (= op.mode :imm) (int8-to-bytes op.arg) + (= op.mode :rel) + (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) + (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg)) + (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg)) + "")] + (if opbyte + (.. (int8-to-bytes opbyte) argbytes) + (error (.. op.opcode " doesn't support mode " op.mode)))) + "")) + + +{: opcodes : op-pdat : parse-mode-arg} diff --git a/asm/65816.fnl b/asm/65816.fnl index 61ae073..687276d 100644 --- a/asm/65816.fnl +++ b/asm/65816.fnl @@ -1,3 +1,5 @@ +(local {: int8-to-bytes : int16-to-bytes} (require "lib.util")) + (local opcodes {}) ; http://www.oxyron.de/html/opcodes816.html @@ -43,23 +45,16 @@ (each [mnemonic modemap (pairs mnemonic-to-modemap)] (tset opcodes mnemonic (fn [mode] (. modemap (or mode :nil)))))) -(fn size [mode] - (match mode - (where (or :imm :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2 - (where (or :abs :abx :aby :ind :iax :rell :bm)) 3 - (where (or :abl :alx :ial)) 4 - nil 1 - _ (error (.. "unknown mode " mode)))) - (fn dp-addr [addr] (when (and (= (type addr) :string) (= (addr:sub 1 1) :d)) (tonumber (addr:sub 2)))) +(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr))) (fn parse-mode-arg [op] (match op (where [mvx srcbank dstbank] - (= (type srcbank) :number) (= (type dstbank :number)) (= (mvx:sub 1 2) :mv)) - [:bm srcbank dstbank] + (= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv)) + [:bm [srcbank dstbank]] (where [_ imm] (or (= (type imm) :number) (= (type imm) :function))) [:imm imm] [_ offset :s] [:sr offset] [_ [[addr]] :y] [:idly addr] @@ -86,7 +81,53 @@ ; we'll assume local bank for now and fix up bankswitching in :patch [_ addr :x] [:abx addr] [_ addr] [:abs addr] - )) - + [_] [nil nil] + _ (error (.. "Unrecognized syntax" (fv op))))) + ; abl = $000000 ; alx = $000000,X +(local op-pdat {}) +(fn addr-page [addr] (math.floor (/ addr 0x10000))) +(fn op-pdat.patch [op env] + (local long-mode (match op.opcode :abs :abl :abx :alx)) + (when (and long-mode (not= (addr-page (env:lookup-org op.arg)) + (addr-page env.root-block.org))) + (set op.mode long-mode))) + +(fn op-pdat.size [op env] +; TODO: handle 8-bit modes + (match op.mode + (where (or :sr :dp :dpx :dpy :idp :idx :idy :idl :idly :isy :rel)) 2 + :imm 3 ;; todo: support 8-bit immediate mode + (where (or :abs :abx :aby :ind :iax :rell :bm)) 3 + (where (or :abl :alx :ial)) 4 + nil 1 + _ (error (.. "unknown mode " op.mode)))) +(fn int24-to-bytes [i] (.. (int8-to-bytes (addr-page i)) (int16-to-bytes (bit.band i 0xffff)))) + +(fn op-pdat.bytes [op env] + (local bytegen (. opcodes op.opcode)) +; (pp op) + (if bytegen + (let [opbyte (bytegen op.mode) + argbytes + (if + (or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes op.arg) + (= op.mode :bm) (.. (int8-to-bytes (. op.arg 1)) (int8-to-bytes (. op.arg 2))) + (and (= op.mode :imm) (= (type op.arg) "function")) + (int16-to-bytes (op.arg env)) + (= op.mode :imm) (int16-to-bytes op.arg) + (= op.mode :rel) + (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) + (= op.mode :rell) + (int16-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 3))) + (= (op-pdat.size op) 2) (int8-to-bytes (env:lookup-addr op.arg)) + (= (op-pdat.size op) 3) (int16-to-bytes (env:lookup-addr op.arg)) + (= (op-pdat.size op) 4) (int24-to-bytes (env:lookup-addr op.arg)) + "")] + (if opbyte + (.. (int8-to-bytes opbyte) argbytes) + (error (.. op.opcode " doesn't support mode " op.mode)))) + "")) + +{: opcodes : parse-mode-arg : op-pdat : addr-parser} diff --git a/asm/asm.fnl b/asm/asm.fnl index 46cced1..778adcd 100644 --- a/asm/asm.fnl +++ b/asm/asm.fnl @@ -1,98 +1,16 @@ (local lume (require "lib.lume")) (local {: int8-to-bytes : int16-to-bytes} (require "lib.util")) -(local opcodes {}) - -; op mode arg -; single-byte ops -(let [ops - {:php 0x08 :plp 0x28 :pha 0x48 :pla 0x68 :dey 0x88 :tay 0xa8 :iny 0xc8 :inx 0xe8 - :clc 0x18 :sec 0x38 :cli 0x58 :sei 0x78 :tya 0x98 :clv 0xb8 :cld 0xd8 :sed 0xf8 - :txa 0x8a :txs 0x9a :tax 0xaa :tsx 0xba :dex 0xca :nop 0xea :rti 0x40 :rts 0x60}] - (each [opcode byte (pairs ops)] - (tset opcodes opcode (fn [mode] (if mode nil byte))))) -(set opcodes.brk (fn [mode] (if (or (= mode :imm) (= mode nil)) 0x00 nil))) - -; branch ops -(let [ops {:bpl 0x10 :bmi 0x30 :bvc 0x50 :bvs 0x70 :bcc 0x90 :bcs 0xb0 :bne 0xd0 :beq 0xf0}] - (each [opcode byte (pairs ops)] - (tset opcodes opcode (fn [mode] (if (= mode :rel) byte nil))))) -(set opcodes.jsr (fn [mode] (if (= mode :abs) 0x20 nil))) - -; aaabbbcc ops -(fn aaabbbcc [aaa cc modemap] - (local base (bit.bor cc (bit.lshift aaa 5))) - (fn [mode] - (local bbb (. modemap mode)) - (if bbb (bit.bor base (bit.lshift bbb 2)) nil))) - -(fn indexed-modes [...] - (let [modemap {}] - (each [index mode (pairs [...])] - (tset modemap mode (- index 1))) - modemap)) - -(fn without-modes [modemap ...] - (let [newmodemap (lume.clone modemap)] - (each [_ mode (pairs [...])] - (tset newmodemap mode nil)) - newmodemap)) - -(fn only-modes [modemap ...] - (let [newmodemap {}] - (each [_ mode (pairs [...])] - (tset newmodemap mode (. modemap mode))) - newmodemap)) - -; cc=1 ops -(let [cc1-modes (indexed-modes :zp-x* :zp :imm :abs :zp*-y :zp-x :abs-y :abs-x) - ops {:ora 0 :and 1 :eor 2 :adc 3 :lda 5 :cmp 6 :sbc 7}] - (each [opcode aaa (pairs ops)] - (tset opcodes opcode (aaabbbcc aaa 1 cc1-modes)) - (tset opcodes :sta (aaabbbcc 4 1 (without-modes cc1-modes :imm))))) -; cc=2 ops -(let [cc2-modes (indexed-modes nil :zp :a :abs nil :zp-x nil :abs-x)] - (each [opcode aaa (pairs {:asl 0 :rol 1 :lsr 2 :ror 3})] - (tset opcodes opcode (aaabbbcc aaa 2 cc2-modes)) - (each [opcode aaa (pairs {:dec 6 :inc 7})] - (tset opcodes opcode (aaabbbcc aaa 2 (without-modes cc2-modes :a)))))) -(tset opcodes :stx (aaabbbcc 4 2 (indexed-modes nil :zp nil :abs nil nil :zp-y))) -(tset opcodes :ldx (aaabbbcc 5 2 (indexed-modes :imm :zp nil :abs nil nil :zp-y nil :abs-y))) - -; cc=0 ops -(let [cc0-modes (indexed-modes :imm :zp nil :abs nil :zp-x nil :abs-x)] - (tset opcodes :bit (aaabbbcc 1 0 (only-modes cc0-modes :zp :abs))) - (tset opcodes :sty (aaabbbcc 4 0 (only-modes cc0-modes :zp :abs :zp-x))) - (tset opcodes :ldy (aaabbbcc 5 0 cc0-modes)) - (each [opcode aaa (pairs {:cpy 6 :cpx 7})] - (tset opcodes opcode (aaabbbcc aaa 0 (only-modes cc0-modes :imm :zp :abs))))) -(tset opcodes :jmp (fn [mode] (match mode :abs 0x4c :abs* 0x6c _ nil))) - -(fn size [mode] - (if - (or (= mode nil) (= mode :a)) 1 - (= (mode:sub 1 3) :abs) 3 - 2)) -(fn opsize [op] (if (= op.opcode :block) 0 (size op.mode))) - -(fn parse-mode-arg [op] - (match op - [_ :a] [:a nil] - ([_ imm] ? (or (= (type imm) "number") (= (type imm) "function"))) [:imm imm] - ([opcode addr] ? (and (= (type addr) "string") (= (opcode:sub 1 1) "b"))) [:rel addr] ; branch - [_ addr :x] [:addr-x addr] - [_ [addr] :y] [:zp*-y addr] - [_ addr :y] [:addr-y addr] - [_ [addr :x]] [:zp-x* addr] - ([_ addr] ? (= (type addr) "string")) [:addr addr] - [_ [addr]] [:abs* addr] - [_] [nil nil] - _ (error (.. "Unrecognized syntax" (fv op))))) (fn make-env [block parent] {:parent parent + :prg (or parent.prg parent) + :root-block (or parent.root-block block) :block block - ; todo: support local self-reference if org is set to zp - :is-zp? (fn [self name] (if (. self.block.symbols name) false (self.parent:is-zp? name))) + :lookup-org + (fn [self name] + (if (or (. self.block.symbols name) (. self.block.globals name)) + self.root-block.org + (self.parent:lookup-org name))) :lookup-addr (fn [self name] (local ipdat (. self.block.symbols name)) @@ -110,7 +28,8 @@ (self.parent:lookup-addr name)))}) -(fn program [prg-base] +(fn program [prg-base ?processor] + (local {: opcodes : op-pdat : parse-mode-arg : addr-parser} (require (.. :asm. (or ?processor :6502)))) ; dat - anything that takes up space in the assembled output (op, dw, db, etc) ; takes the form [:op args] ; pdat - a parsed dat; takes the form {:type type :addr addr ...} @@ -178,7 +97,7 @@ preserve-block)) (local pdat-processor { - :op {} + :op op-pdat :var {} :ref {} :raw {} @@ -191,43 +110,17 @@ (if ok (values ...) (do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "") " @" (or pdat.addr "") " - " ...))))) (local processor (. pdat-processor pdat.type process)) - (if processor (complain (pcall #(processor pdat $...) ...)) default)) - - (fn pdat-processor.op.patch [op env] - (when (and op.mode (= (op.mode:sub 1 4) :addr)) - (let [zp-mode (.. :zp (op.mode:sub 5)) - abs-mode (.. :abs (op.mode:sub 5)) - is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))] - (set op.mode (if is-zp zp-mode abs-mode))))) + (let [(a1 a2 a3 a4 a5) ...] + (if processor (complain (xpcall #(processor pdat a1 a2 a3 a4 a5) fennel.traceback)) default))) +; (if processor (complain (pcall #(processor pdat $...) ...)) default)) (fn pdat-processor.raw.size [raw] (length raw.bytes)) - (fn pdat-processor.op.size [op] (size op.mode)) (fn pdat-processor.var.size [d] d.size) (fn pdat-processor.ref.size [r] 2) (fn pdat-processor.pad.size [pad] (let [misalignment (% pad.addr pad.align)] (if (= misalignment 0) 0 (- pad.align misalignment)))) - (fn pdat-processor.op.bytes [op env] - (local bytegen (. opcodes op.opcode)) - ; (pp op) - (if bytegen - (let [opbyte (bytegen op.mode) - argbytes - (if - (and (= op.mode :imm) (= (type op.arg) "function")) - (int8-to-bytes (op.arg env)) - - (= op.mode :imm) (int8-to-bytes op.arg) - (= op.mode :rel) - (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2))) - (= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg)) - (= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg)) - "")] - (if opbyte - (.. (int8-to-bytes opbyte) argbytes) - (error (.. op.opcode " doesn't support mode " op.mode)))) - "")) (fn pdat-processor.var.bytes [d env] (local init (match (type d.init) :number d.init @@ -297,7 +190,8 @@ (var block (. self.org-to-block org)) (when (not block) (set block (new-block)) - (tset self.org-to-block org block)) + (tset self.org-to-block org block) + (set block.org org)) {: block : org :prg self @@ -305,14 +199,8 @@ :append (fn [self ...] (self.prg:dbg self.org ...) (parse-dats self.block [...]) self)}) :parse-addr (fn [self name] - (local addr (tonumber name)) + (local addr ((or addr-parser tonumber) name)) (if addr addr (error (.. "Symbol '" name "' not found")))) - :is-zp? - (fn [self name] - (local org (. self.symbol-to-org name)) - (if org (< org 0x100) - self.prg-base (self.prg-base:is-zp? name) - (< (self:parse-addr name) 0x100))) :env-lookup (fn [self name lookup ...] (local org (. self.symbol-to-org name)) @@ -324,6 +212,9 @@ (fn [self name] ; (print "looking up" name "in" self) (or (self:env-lookup name :lookup-addr) (self:parse-addr name))) + :lookup-org + (fn [self name] + (or (self:env-lookup name :lookup-org) (self:parse-addr name))) :pass (fn [self passname] (print passname) diff --git a/main.lua b/main.lua index e7b4c91..f71ba44 100644 --- a/main.lua +++ b/main.lua @@ -1,6 +1,7 @@ -- bootstrap the compiler fennel = require("lib.fennel") table.insert(package.loaders, fennel.make_searcher()) +debug.traceback = fennel.traceback fv = fennel.view pp = function(x) print(fv(x)) end lume = require("lib.lume")