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