Initial false start with Racket

ops.rkt

@@ -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)]))]))

thinks.txt

@@ -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)
+