Initial false start with Racket

This commit is contained in:
Jeremy Penner 2020-08-22 15:05:42 -04:00
commit 0eb081d040
2 changed files with 230 additions and 0 deletions

192
ops.rkt Normal file
View file

@ -0,0 +1,192 @@
#lang racket
; 4 stages:
; DEFINITION: at this stage, labels must be defined as pointing to zero page memory or not
; SIZING: given the definitions, how big is each piece?
; ALLOCATION: knowing how big each piece is now allows us to assign concrete addresses to labels
; GENERATION: with addresses calculated, we can now generate the correct machine language code
; env: symbol -> def
; DEFINITION: (label, area, sizer)
; SIZING: (sizer denv) -> (size, generator)
; ALLOCATION: (label, area, sizer) -> (label, address, generator)
; GENERATION: (generator aenv) -> bytes
; two kinds of labels:
; lexical (local) labels: not exported from the containing block, generally used by relative branches
; global labels: can be referred to from anywhere
(require racket/generic)
(define-generics address-def
(zeropage? address-def))
(define-generics op
(size op env)
(gen-bytes op env addr))
(struct area (addrStart addrEnd) #:transparent
#:methods gen:address-def
[(define (zeropage? area) (< (area-addrEnd area) #x100))])
(struct addr (addr) #:transparent
#:methods gen:address-def
[(define (zeropage? addr) (< (addr-addr addr) #x100))])
(define zp (area #x00 #xff))
(define stack (area #x0100 #x01ff))
(define 300hole (area #x0300 #x03cf))
(define grpage1 (area #x0400 #x07ff))
(define grpage2 (area #x0800 #x0bff))
(define c00hole (area #xc00 #x1fff))
(define page1 (area #x2000 #x3fff))
(define page2 (area #x4000 #x5fff))
(define freespace (area #x6000 #x95ff))
(struct op-singlebyte (byte) #:transparent
#:methods gen:op
[(define (size op env) 1)
(define (gen-bytes op env addr) (bytes (op-singlebyte-byte op)))])
(define (get-addr env sym-or-addr)
(if (addr? sym-or-addr) sym-or-addr
(hash-ref env sym-or-addr)))
(define (mode-from-arg env arg)
(define (if-zp addr zpmode nonzpmode)
(let [(resolved (get-addr env addr))]
(list
(if (zeropage? resolved) zpmode nonzpmode)
resolved)))
(match arg
[(list imm) #:when (number? imm) (list 'imm imm)]
[(list addr 'x) (if-zp addr 'zp-x 'abs-x)]
[(list addr 'y) (if-zp addr 'zp-y 'abs-y)]
[(list addr) (if-zp addr 'zp 'abs)]
[(list 'a) (list 'a #f)]
[(list (list addr)) (list 'abs* (get-addr addr))]
[(list (list addr) 'y) (if-zp addr 'zp*-y #f)]
[(list (list addr 'x)) (if-zp addr 'zp-x* #f)]
[else #f]))
(struct op-arg (base modes arg) #:transparent
#:methods gen:op
[(define (size op env)
(match (mode-from-arg env (op-arg-arg op))
[(list _ #f) 1]
[(list mode _) #:when (string-prefix? (symbol->string mode) "abs") 3]
[else 2]))
(define (gen-bytes op env addr)
(let* [(modes (op-arg-modes op))
(mode-val (mode-from-arg env (op-arg-arg op)))
(mode (car mode-val))
(val (cadr mode-val))
(byte (modes (op-arg-base op) mode))]
(case (size op env)
[(1) (bytes byte)]
[(2) (bytes byte (bitwise-and val #xff))]
[(3) (bytes byte (bitwise-and val #xff) (bitwise-and (arithmetic-shift val -8) #xff))])))])
(struct op-branch (byte target) #:transparent
#:methods gen:op
[(define (size op env) 2)
(define (gen-bytes op env addr)
(let* [(dst-addr (get-addr env (op-branch-target op)))
(rel (- (+ addr 2) (addr-addr dst-addr)))]
(bytes (op-branch-byte op) (bitwise-and rel #xff))))])
(define-syntax (make-ops stx)
(syntax-case stx ()
[(_ op-maker ops ...)
#`(begin
#,@(for/list [(op (syntax->list #'(ops ...)))]
#`(op-maker #,@op)))]))
(define-syntax-rule (make-singlebyte-op op byte)
(begin
(define (op) (op-singlebyte byte))
(provide op)))
(make-ops make-singlebyte-op
(php #x08) (plp #x28) (pha #x48) (pla #x68) (dey #x88) (tay #xa8) (iny #xc8) (inx #xe8)
(clc #x18) (sec #x38) (cli #x58) (sei #x78) (tya #x98) (clv #xb8) (cld #xd8) (sed #xf8)
(txa #x8a) (txs #x9a) (tax #xaa) (tsx #xba) (dex #xca) (nop #xea) (brk #x00) (rti #x40)
(rts #x60))
(define-syntax-rule (make-arg-op op base modes)
(begin
(define (op . arg) (op-arg base modes arg))
(provide op)))
(define (indexed-modes modelist)
(lambda (base mode)
(match (index-of modelist mode)
[imode #:when (number? imode) (bitwise-ior base (arithmetic-shift imode 2))]
[#f #f])))
(define (without-modes modes . ignored-modes)
(lambda (base mode) (if (member mode ignored-modes) #f (modes base mode))))
(define (only-modes modes . mode-subset)
(lambda (base mode) (if (member mode mode-subset) (modes base mode) #f)))
(define (override-modes lmodes rmodes)
(lambda (base mode) (let [(lmode (lmodes base mode))] (if lmode lmode (rmodes base mode)))))
(define (make-base aaa cc)
(bitwise-ior cc (arithmetic-shift aaa 5)))
(define-syntax (make-cc-ops stx)
(syntax-case stx ()
[(_ cc modes ops ...)
#`(begin
#,@(for/list [(op (syntax->list #'(ops ...)))]
(syntax-case op ()
[(opname base)
#'(make-arg-op opname (make-base base cc) modes)])))]))
(define cc1-modes (indexed-modes '(zp-x* zp imm abs zp*-y zp-x abs-y abs-x)))
(make-cc-ops 1 cc1-modes
(ora 0) (and 1) (eor 2) (adc 3) (lda 5) (cmp 6) (sbc 7))
(make-arg-op sta (make-base 4 1) (without-modes cc1-modes 'imm))
(define cc2-modes (indexed-modes '(imm zp a abs _ zp-x _ asb-x)))
(make-cc-ops 2 (without-modes cc2-modes 'imm)
(asl 0) (rol 1) (lsr 2) (ror 3))
(make-arg-op stx (make-base 4 2) (indexed-modes '(_ zp _ abs _ _ zp-y)))
(make-arg-op ldx (make-base 5 2) (indexed-modes '(imm zp _ abs _ _ zp-y _ abs-y)))
(make-cc-ops 2 (without-modes cc2-modes 'imm 'a)
(dec 6) (inc 7))
(define cc0-modes (indexed-modes '(imm zp _ abs _ zp-x _ abs-x)))
(make-arg-op bit (make-base 1 0) (only-modes cc0-modes 'zp 'abs))
(make-arg-op jmp (make-base 2 0)
(lambda (base mode)
(case mode
[('abs) #x4c]
[('abs*) #x6c]
[else #f])))
(make-arg-op sty (make-base 4 0) (only-modes cc0-modes 'zp 'abs 'zp-x))
(make-arg-op ldy (make-base 5 0) cc0-modes)
(make-cc-ops 0 (only-modes cc0-modes 'imm 'zp 'abs)
(cpy 6) (cpx 7))
(define-syntax-rule (make-branch-op op byte)
(begin
(define (op target) (op-branch byte target))
(provide op)))
(make-ops make-branch-op
(bpl #x10) (bmi #x30) (bvc #x50) (bvs #x70) (bcc #x90) (bcs #xb0) (bne #xd0) (beq #xf0))
(struct block (oplist area labels exported) #:transparent
#:methods gen:op
[(define (size block env)
(let [(new-env
(for/fold [(new-env env)]
[(label (hash-keys (block-labels block)))]
(hash-set new-env label (block-area block))))]
(for/sum [(op (block-oplist block))] (size op))))
(define (gen-bytes block env addr)
(let-values
[([end-addr iop-to-addr cop]
(for/fold [(curr-addr addr) (iop-to-addr #hash()) (iop 0)]
[(op (block-oplist block))]
(let* [(opsize (size op env))
(next-addr (+ addr opsize))]
(values next-addr (hash-set iop-to-addr iop curr-addr) (+ iop 1)))))]))])
; draw the rest of the fucking owl
(define defblock (area ops)
(let [(oplist
(for/fold [(i 0) (oplist)]))]))

38
thinks.txt Normal file
View file

@ -0,0 +1,38 @@
GOAL:
live-program an emulator in assembly
- a program is a graph that is flattened into a set of bytestreams.
- first step: make the damn graph.
APPROACH:
- program is split into "ROM" and "RAM" - ROM is code that generally doesn't change while the program is running, RAM is program data
- a program is assembled from snippets that refer to other snippets by name
- a code snippet can be marked as a "loop point", a safe spot to pause and replace a running program's code
- this is also be a good spot to take snapshots of "RAM" which we could roll back to
- this assumes an empty stack + no code references in RAM - perhaps a special typed variable is needed for snippet pointers?
- for now, we will depend on gsplus' socket-based remote debugging capabilities to poke the program into emulated memory
WHAT IS A SNIPPET
- label + block
- block = bytestring, labels (offset into instruction list), fixups (label references)
- can concatenate blocks; snippets are stored "loose" - accessed by absolute JMP or JSR
- other compositional ideas:
- "scopes" - keep labels "alive" only for a short period, for autogenerated loops, if statements, etc
- could also just gensym
(lda 13) ; immediate
(lda (addr #x2000)) ; absolute
(lda (addr #x20)) ; zero-page
(lda (off-x (addr #x20))) ; zp,x
(lda (off-y (addr #x20))) ; zp,y
(lda (off-x@ (addr #x20))) ; (zp,x)
(lda (@off-y (addr #x20))) ; (zp),y
(lda (off-x (addr #x2000))) ; abs,x
(lda (off-y (addr #x2000))) ; abs,y
label = lazy address
maybe treat zero-page and absolute as different types? we will always plan what goes into zero-page. zp has addressing modes abs doesn't.
each opcode is a function that returns a block, usually 0-3 bytes with optionally associated labels + fixups
(fixup is a tuple: local offset, label reference, and whether we're expecting an absolute, zero-page, or relative address)