mars.scm

   1 ;;;
   2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
   3 ;;;
   4
   5 (import (chicken io)
   6         (chicken string)
   7         (chicken random)
   8         (chicken condition)
   9         (chicken process-context)
  10         matchable)
  11
  12
  13 ;;; Instructions
  14 ;;
  15
  16 (define (make-instr opcode modifier A-mode A-num B-mode B-num)
  17   (lambda args
  18     (match args
  19       (('opcode) opcode)
  20       (('modifier) modifier)
  21       (('A-mode) A-mode)
  22       (('A-num) A-num)
  23       (('B-mode) B-mode)
  24       (('B-num) B-num)
  25       (('make-copy) (make-instr opcode modifier A-mode A-num B-mode B-num))
  26       (('set! 'opcode x) (set! opcode x))
  27       (('set! 'modifier x) (set! modifier x))
  28       (('set! 'A-mode x) (set! A-mode x))
  29       (('set! 'A-num x) (set! A-num x))
  30       (('set! 'B-mode x) (set! B-mode x))
  31       (('set! 'B-num x) (set! B-num x))
  32       (('set-from! other)
  33        (set! opcode (other 'opcode))
  34        (set! modifier (other 'modifier))
  35        (set! A-mode (other 'A-mode))
  36        (set! A-num (other 'A-num))
  37        (set! B-mode (other 'B-mode))
  38        (set! B-num (other 'B-num)))
  39       (('->string)
  40        (conc opcode
  41              "." modifier
  42              " " (mode->string A-mode) A-num
  43              " " (mode->string B-mode) B-num))
  44       (else
  45        (error "Invalid instr arguments" args)))))
  46
  47 (define (mode->string mode)
  48   (case mode
  49     ((immediate) "#")
  50     ((direct) "$")
  51     ((indirect-A) "*")
  52     ((indirect-B) "@")
  53     ((pre-indirect-A) "{")
  54     ((pre-indirect-B) "<")
  55     ((post-indirect-A) "}")
  56     ((post-indirect-B) ">")
  57     (else
  58      (error "Unknown mode."))))
  59
  60 (define initial-instruction
  61   (make-instr 'DAT 'F 'immediate 0 'immediate 0))
  62
  63
  64 ;;; Memory setup and addressing
  65 ;;
  66
  67 (define (make-core core-size initial-instr)
  68   (let ((core-vec (make-vector core-size '()))
  69         (names-vec (make-vector core-size '())))
  70     (let loop ((i 0))
  71       (unless (>= i core-size)
  72         (vector-set! core-vec i (initial-instr 'make-copy))
  73         (loop (+ i 1))))
  74     (lambda args
  75       (match args
  76         ((i 'set-from! j n)
  77          ((vector-ref core-vec i) 'set-from! (vector-ref core-vec j))
  78          (vector-set! names-vec i n))
  79         ((i 'set-from-instr! instr n)
  80          ((vector-ref core-vec i) 'set-from! instr)
  81          (vector-set! names-vec i n))
  82         ((i 'set! v x n)
  83          ((vector-ref core-vec i) 'set! v x)
  84          (vector-set! names-vec i n))
  85         ((i 'name) (vector-ref names-vec i))
  86         ((i v) ((vector-ref core-vec i) v))
  87         (('dump)
  88          (let loop ((i 0))
  89            (unless (>= i core-size)
  90              (print* i ":\t" ((vector-ref core-vec i) '->string))
  91              (let ((n (vector-ref names-vec i)))
  92                (unless (null? n)
  93                  (print* "\t;" n)))
  94              (print)
  95              (loop (+ i 1)))))))))
  96
  97 (define (addr+ . args)
  98   (foldl (lambda (a b)
  99            (modulo (+ a b core-size) core-size))
 100          0 args))
 101
 102 ;;; Programmes and task queues
 103 ;;
 104
 105 (define (make-prog name instrs offset)
 106   (list name instrs offset))
 107
 108 (define (prog-name prog) (list-ref prog 0))
 109 (define (prog-instrs prog) (list-ref prog 1))
 110 (define (prog-offset prog) (list-ref prog 2))
 111
 112 (define (install-prog core prog addr)
 113   (let loop ((ptr addr)
 114              (instrs (prog-instrs prog)))
 115     (unless (null? instrs)
 116       (core ptr 'set-from-instr! (car instrs) (prog-name prog))
 117       (loop (addr+ ptr 1) (cdr instrs))))
 118   (make-queue (prog-name prog)
 119               (addr+ addr (prog-offset prog))))
 120
 121 (define (can-install-prog? core prog-len addr)
 122   (let loop ((ptr addr)
 123              (remaining prog-len))
 124     (if (= remaining 0)
 125         #t
 126         (if (null? (core ptr 'name))
 127             (loop (addr+ ptr 1)
 128                   (- remaining 1))
 129             #f))))
 130
 131 (define (install-progs core progs)
 132   (let loop ((queues '())
 133              (progs-left progs))
 134     (if (null? progs-left)
 135         queues
 136         (let ((addr (pseudo-random-integer core-size))
 137               (prog (car progs-left)))
 138           (if (can-install-prog? core (length (prog-instrs prog)) addr)
 139               (loop (cons (install-prog core prog addr) queues)
 140                     (cdr progs-left))
 141               (loop queues progs-left))))))
 142
 143 (define (make-queue name ptr)
 144   (list name ptr))
 145
 146 (define (queue-owner queue) (car queue))
 147 (define (queue-ptrs queue) (cdr queue))
 148
 149 (define (queue-set-ptrs! queue ptrs)
 150   (set-cdr! queue ptrs))
 151
 152
 153 ;;; Executive function
 154 ;;
 155
 156 (define (run core queues steps-left)
 157   (cond
 158    ((<= steps-left 0) queues)      ;Tie between remaining players
 159    ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
 160    (else
 161     (let* ((queue (car queues))
 162            (remaining-queues (cdr queues))
 163            (ptrs (queue-ptrs queue))
 164            (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
 165       (if (null? new-ptrs)
 166           (run remaining-queues (- steps-left 1))
 167           (begin
 168             (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
 169             (run core (append remaining-queues (list queue)) (- steps-left 1))))))))
 170
 171 (define (execute-instr core ptr name)
 172   (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
 173          (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
 174          (modifier (core ptr 'modifier)))
 175     (case (core ptr 'opcode)
 176       ((DAT)
 177        '()) ;Game over, man, game over!
 178       ((MOV)
 179        (if (eq? modifier 'I)
 180            (core B-ptr 'set-from! A-ptr name)
 181            (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
 182        (list (addr+ ptr 1)))
 183       ((ADD)
 184        (combine-and-store core A-ptr B-ptr modifier name addr+)
 185        (list (addr+ ptr 1)))
 186       ((SUB)
 187        (combine-and-store core A-ptr B-ptr modifier name
 188                           (lambda (x y) (addr+ x (- y))))
 189        (list (addr+ ptr 1)))
 190       ((MUL)
 191        (combine-and-store core A-ptr B-ptr modifier name
 192                           (lambda (x y) (modulo (* (addr+ x core-size)
 193                                                    (addr+ y core-size))
 194                                                 core-size)))
 195        (list (addr+ ptr 1)))
 196       ((DIV)
 197        (condition-case
 198            (begin
 199              (combine-and-store core A-ptr B-ptr modifier name
 200                                 (lambda (x y) (quotient (addr x core-size)
 201                                                         (addr y core-size))))
 202              (list (addr+ ptr 1)))
 203          ((exn arithmetic) '())))
 204       ((MOD)
 205        (condition-case
 206            (begin
 207              (combine-and-store core A-ptr B-ptr modifier name
 208                                 (lambda (x y) (remainder (addr x core-size)
 209                                                          (addr y core-size))))
 210              (list (addr+ ptr 1)))
 211          ((exn arithmetic) '())))
 212       ((JMP)
 213        (list (addr+ ptr (core A-ptr 'A-num))))
 214       ((JMZ)
 215        (list (addr+ ptr (if (instr-zero? B-ptr modifier #f name)
 216                             (core A-ptr 'A-num)
 217                             1))))
 218       ((JMN)
 219        (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f name))
 220                             (core A-ptr 'A-num)
 221                             1))))
 222       ((DJN)
 223        (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t name))
 224                             (core A-ptr 'A-num)
 225                             1))))
 226       ((SEQ CMP)
 227        (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1))))
 228       ((SNE)
 229        (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2))))
 230       ((SLT)
 231        (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1))))
 232       ((SPL)
 233        (list (addr+ ptr 1) (addr+ ptr (core A-ptr 'A-num))))
 234       ((NOP)
 235        (list (addr+ ptr 1)))
 236       (else
 237        (error "Unrecognised opcode" (instr 'opcode))))))
 238
 239 (define (compare-instrs core A-ptr B-ptr modifier test)
 240   (case modifier
 241     ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
 242     ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
 243     ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
 244     ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
 245     ((F) (and
 246           (test (core A-ptr 'A-num) (core B-ptr 'A-num))
 247           (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
 248     ((X) (and
 249           (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 250           (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
 251     ((I) (and
 252           (if (eq? test =)
 253               (and
 254                (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
 255                (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
 256                (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
 257                (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
 258               #t)
 259           (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 260           (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
 261
 262 (define (instr-zero? core ptr modifier decrement name)
 263   (case modifier
 264     ((A AB)
 265      (if decrement (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name))
 266      (= 0 (core ptr 'A-num)))
 267     ((A AB)
 268      (if decrement (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name))
 269      (= 0 (core ptr 'B-num)))
 270     ((X I F)
 271      (if decrement
 272          (begin
 273            (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name)
 274            (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name)))
 275      (and (= 0 (core ptr 'A-num))
 276           (= 0 (core ptr 'B-num))))))
 277
 278 (define (combine-and-store core A-ptr B-ptr modifier name f)
 279   (case modifier
 280     ((A) (core B-ptr 'set! 'A-num
 281                (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name))
 282     ((B) (core B-ptr 'set! 'B-num
 283                (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
 284     ((AB) (core B-ptr 'set! 'B-num
 285                 (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))
 286     ((BA) (core B-ptr 'set! 'A-num
 287                 (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name))
 288     ((F I) (core B-ptr 'set! 'A-num
 289                  (f (core B-ptr 'A-num) (core A-ptr 'A-num)) name)
 290            (core B-ptr 'set! 'B-num
 291                  (f (core B-ptr 'B-num) (core A-ptr 'B-num)) name))
 292     ((X) (core B-ptr 'set! 'A-num
 293                (f (core B-ptr 'A-num) (core A-ptr 'B-num)) name)
 294          (core B-ptr 'set! 'B-num
 295                (f (core B-ptr 'B-num) (core A-ptr 'A-num)) name))))
 296
 297 (define (eval-operand core mode num ptr name)
 298   (addr+ ptr
 299          (case mode
 300            ((immediate) 0)
 301            ((direct) num)
 302            ((indirect-A) (addr+ num (core (addr+ ptr num) 'A-num)))
 303            ((indirect-B) (addr+ num (core (addr+ ptr num) 'B-num)))
 304            ((pre-indirect-A)
 305             (let ((aux-ptr (addr+ ptr num)))
 306               (core aux-ptr 'set! 'A-num (addr+ -1 (core aux-ptr 'A-num)) name)
 307               (addr+ num (core aux-ptr 'A-num))))
 308            ((pre-indirect-B)
 309             (let ((aux-ptr (addr+ ptr num)))
 310               (core aux-ptr 'set! 'B-num (addr+ -1 (core aux-ptr 'B-num)) name)
 311               (addr+ num (core aux-ptr 'B-num))))
 312            ((post-indirect-A)
 313             (let* ((aux-ptr (addr+ ptr num))
 314                    (old-A-num (core aux-ptr 'A-num)))
 315               (core aux-ptr 'set! 'A-num (addr+ 1 (core aux-ptr 'A-num)) name)
 316               (addr+ num old-A-num)))
 317            ((post-indirect-B)
 318             (let* ((aux-ptr (addr+ ptr num))
 319                    (old-B-num (core aux-ptr 'B-num)))
 320               (core aux-ptr 'set! 'B-num (addr+ 1 (core aux-ptr 'B-num)) name)
 321               (addr+ num old-B-num)))
 322            (else
 323             (error "Unrecognized mode" mode)))))
 324
 325 ;;; Main procedure
 326 ;;
 327
 328 ;;; TEST CODE
 329
 330 (define addressing-test
 331   (make-prog 'at (list
 332                    (make-instr 'DAT 'F 'immediate 42 'immediate 53)
 333                    (make-instr 'DAT 'F 'immediate 123 'immediate 256)
 334                    (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
 335                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 336                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 337                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 338                    (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
 339
 340 (define imp
 341   (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
 342
 343 (define dwarf
 344   (make-prog 'dwarf (list
 345                      (make-instr 'DAT 'F 'immediate 0 'immediate -1)
 346                      (make-instr 'ADD 'AB 'immediate 5 'direct -1)
 347                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
 348                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
 349
 350 (define core (make-core 20 (make-instr 'DAT 'F 'immediate 0 'immediate 0)))
 351 (define queues (install-progs core (list dwarf imp)))