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