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