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