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