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 wish)
  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 . set-functions)
  68   (let ((core-vec (make-vector core-size '()))
  69         (names-vec (make-vector core-size '())))
  70     (define (norm-addr i)
  71       (if (< i 0)
  72           (norm-addr (+ i core-size))
  73           (modulo i core-size)))
  74     (define (norm-ref v i)
  75       (vector-ref v (norm-addr i)))
  76     (define (norm-set! v i x)
  77       (vector-set! v (norm-addr i)
  78                    (if (integer? x)
  79                        (norm-addr x)
  80                        x)))
  81     (define (run-set-functions i n)
  82       (let loop ((remaining-fns set-functions))
  83         (unless (null? remaining-fns)
  84           ((car remaining-fns) i n))))
  85     (let loop ((i 0))
  86       (unless (>= i core-size)
  87         (vector-set! core-vec i (initial-instr 'make-copy))
  88         (loop (+ i 1))))
  89     (lambda args
  90       (match args
  91         ((i 'set-from! j n)
  92          ((norm-ref core-vec i) 'set-from! (norm-ref core-vec j))
  93          (norm-set! names-vec i n)
  94          (run-set-functions i n))
  95         ((i 'set-from-instr! instr n)
  96          ((norm-ref core-vec i) 'set-from! instr)
  97          (norm-set! names-vec i n)
  98          (run-set-functions i n))
  99         ((i 'set! v x n)
 100          ((norm-ref core-vec i) 'set! v x)
 101          (norm-set! names-vec i n)
 102          (run-set-functions i n))
 103         ((i 'name) (norm-ref names-vec i))
 104         (((? integer? i) v) ((norm-ref core-vec i) v))
 105         (('->addr (? integer? i)) (norm-addr i))
 106         (('dump)
 107          (let loop ((i 0))
 108            (unless (>= i core-size)
 109              (print* i ":\t" ((vector-ref core-vec i) '->string))
 110              (let ((n (vector-ref names-vec i)))
 111                (unless (null? n)
 112                  (print* "\t;" n)))
 113              (print)
 114              (loop (+ i 1)))))
 115         (('size) core-size)))))
 116
 117
 118 ;;; Programmes and task queues
 119 ;;
 120
 121 (define (make-prog name instrs offset)
 122   (list name instrs offset))
 123
 124 (define (prog-name prog) (list-ref prog 0))
 125 (define (prog-instrs prog) (list-ref prog 1))
 126 (define (prog-offset prog) (list-ref prog 2))
 127
 128 (define (install-prog core prog addr)
 129   (let loop ((ptr addr)
 130              (instrs (prog-instrs prog)))
 131     (unless (null? instrs)
 132       (core ptr 'set-from-instr! (car instrs) (prog-name prog))
 133       (loop (core '->addr (+ ptr 1)) (cdr instrs))))
 134   (make-queue (prog-name prog)
 135               (core '->addr (+ addr (prog-offset prog)))))
 136
 137 (define (can-install-prog? core prog-len addr)
 138   (let loop ((ptr addr)
 139              (remaining prog-len))
 140     (if (= remaining 0)
 141         #t
 142         (if (null? (core ptr 'name))
 143             (loop (core '->addr (+ ptr 1))
 144                   (- remaining 1))
 145             #f))))
 146
 147 (define (install-progs core progs)
 148   (let loop ((queues '())
 149              (progs-left progs))
 150     (if (null? progs-left)
 151         queues
 152         (let ((addr (pseudo-random-integer (core 'size)))
 153               (prog (car progs-left)))
 154           (if (can-install-prog? core (length (prog-instrs prog)) addr)
 155               (loop (cons (install-prog core prog addr) queues)
 156                     (cdr progs-left))
 157               (loop queues progs-left))))))
 158
 159 (define (make-queue name ptr)
 160   (list name ptr))
 161
 162 (define (queue-owner queue) (car queue))
 163 (define (queue-ptrs queue) (cdr queue))
 164
 165 (define (queue-set-ptrs! queue ptrs)
 166   (set-cdr! queue ptrs))
 167
 168
 169 ;;; Executive function
 170 ;;
 171
 172 (define (run core queues steps-left)
 173   (cond
 174    ((<= steps-left 0) queues)      ;Tie between remaining players
 175    ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins
 176    (else
 177     (let* ((queue (car queues))
 178            (remaining-queues (cdr queues))
 179            (ptrs (queue-ptrs queue))
 180            (new-ptrs (execute-instr core (car ptrs) (queue-owner queue))))
 181       (if (null? new-ptrs)
 182           (run remaining-queues (- steps-left 1))
 183           (begin
 184             (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
 185             (run core (append remaining-queues (list queue)) (- steps-left 1))))))))
 186
 187 (define (execute-instr core ptr name)
 188   (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name))
 189          (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name))
 190          (modifier (core ptr 'modifier)))
 191     (case (core ptr 'opcode)
 192       ((DAT)
 193        '()) ;Game over, man, game over!
 194       ((MOV)
 195        (if (eq? modifier 'I)
 196            (core B-ptr 'set-from! A-ptr name)
 197            (combine-and-store core A-ptr B-ptr modifier name (lambda (x y) y)))
 198        (list (core '->addr (+ ptr 1))))
 199       ((ADD)
 200        (combine-and-store core A-ptr B-ptr modifier name +)
 201        (list (core '->addr (+ ptr 1))))
 202       ((SUB)
 203        (combine-and-store core A-ptr B-ptr modifier name -)
 204        (list (core '->addr (+ ptr 1))))
 205       ((MUL)
 206        (combine-and-store core A-ptr B-ptr modifier name *)
 207        (list (core '->addr (+ ptr 1))))
 208       ((DIV)
 209        (condition-case
 210            (begin
 211              (combine-and-store core A-ptr B-ptr modifier name quotient)
 212
 213              (list (core '->addr (+ ptr 1))))
 214          ((exn arithmetic) '())))
 215       ((MOD)
 216        (condition-case
 217            (begin
 218              (combine-and-store core A-ptr B-ptr modifier name modulo)
 219              (list (core '->addr (+ ptr 1))))
 220          ((exn arithmetic) '())))
 221       ((JMP)
 222        (list (core '->addr (+ ptr (core A-ptr 'A-num)))))
 223       ((JMZ)
 224        (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name)
 225                                       (core A-ptr 'A-num)
 226                                       1)))))
 227       ((JMN)
 228        (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name))
 229                                       (core A-ptr 'A-num)
 230                                       1)))))
 231       ((DJN)
 232        (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name))
 233                                       (core A-ptr 'A-num)
 234                                       1)))))
 235       ((SEQ CMP)
 236        (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
 237       ((SNE)
 238        (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
 239       ((SLT)
 240        (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
 241       ((SPL)
 242        (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num))))))
 243       ((NOP)
 244        (list (core '->addr (+ ptr 1))))
 245       (else
 246        (error "Unrecognised opcode" (instr 'opcode))))))
 247
 248 (define (compare-instrs core A-ptr B-ptr modifier test)
 249   (case modifier
 250     ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num)))
 251     ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num)))
 252     ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num)))
 253     ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num)))
 254     ((F) (and
 255           (test (core A-ptr 'A-num) (core B-ptr 'A-num))
 256           (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
 257     ((X) (and
 258           (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 259           (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
 260     ((I) (and
 261           (if (eq? test =)
 262               (and
 263                (eq? (core A-ptr 'opcode) (core B-ptr 'opcode))
 264                (eq? (core A-ptr 'modifier) (core B-ptr 'modifier))
 265                (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode))
 266                (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode)))
 267               #t)
 268           (test (core A-ptr 'A-num) (core B-ptr 'B-num))
 269           (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
 270
 271 (define (instr-zero? core ptr modifier decrement name)
 272   (case modifier
 273     ((A AB)
 274      (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
 275      (= 0 (core ptr 'A-num)))
 276     ((A AB)
 277      (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
 278      (= 0 (core ptr 'B-num)))
 279     ((X I F)
 280      (if decrement
 281          (begin
 282            (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name)
 283            (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name)))
 284      (and (= 0 (core ptr 'A-num))
 285           (= 0 (core ptr '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   (core '->addr (+ ptr
 308                    (case mode
 309                      ((immediate) 0)
 310                      ((direct) num)
 311                      ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
 312                      ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
 313                      ((pre-indirect-A)
 314                       (let ((aux-ptr (+ ptr num)))
 315                         (core aux-ptr 'set! 'A-num (- (core aux-ptr 'A-num) 1) name)
 316                         (+ num (core aux-ptr 'A-num))))
 317                      ((pre-indirect-B)
 318                       (let ((aux-ptr (+ ptr num)))
 319                         (core aux-ptr 'set! 'B-num (- (core aux-ptr 'B-num) 1) name)
 320                         (+ num (core aux-ptr 'B-num))))
 321                      ((post-indirect-A)
 322                       (let* ((aux-ptr (+ ptr num))
 323                              (old-A-num (core aux-ptr 'A-num)))
 324                         (core aux-ptr 'set! 'A-num (+ (core aux-ptr 'A-num) 1) name)
 325                         (+ num old-A-num)))
 326                      ((post-indirect-B)
 327                       (let* ((aux-ptr (+ ptr num))
 328                              (old-B-num (core aux-ptr 'B-num)))
 329                         (core aux-ptr 'set! 'B-num (+ (core aux-ptr 'B-num) 1) name)
 330                         (+ 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)
 342                    (make-instr 'DAT 'F 'immediate 123 'immediate 256)
 343                    (make-instr 'MOV 'A 'indirect-B 4 'direct 7)
 344                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 345                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 346                    (make-instr 'NOP 'I 'immediate 0 'immediate 0)
 347                    (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2))
 348
 349 (define imp
 350   (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0))
 351
 352 (define dwarf
 353   (make-prog 'dwarf (list
 354                      (make-instr 'DAT 'F 'immediate 0 'immediate -1)
 355                      (make-instr 'ADD 'AB 'immediate 5 'direct -1)
 356                      (make-instr 'MOV 'I 'direct -2 'indirect-B -2)
 357                      (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1))
 358
 359 (define palette '((imp . "red")
 360                   (dwarf . "blue")))
 361
 362 (define w (make-wish 640 480 palette))
 363
 364 (define core (make-core (* 640 480) (make-instr 'DAT 'F 'immediate 0 'immediate 0)
 365                         (lambda (i n)
 366                           (set-wish-pixel w
 367                                           (remainder i 640)
 368                                           (quotient i 640)
 369                                           (cdr (assoc n palette))))))
 370 (define queues (install-progs core (list dwarf imp)))
 371