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