mars.scm

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