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