2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
28 (chicken process-context)
35 (define (make-instr opcode modifier A-mode A-num B-mode B-num)
39 (('modifier) modifier)
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))
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)))
61 "\t" (mode->string A-mode) A-num
62 ", " (mode->string B-mode) B-num))
64 (error "Invalid instr arguments" args)))))
66 (define (mode->string mode)
72 ((pre-indirect-A) "{")
73 ((pre-indirect-B) "<")
74 ((post-indirect-A) "}")
75 ((post-indirect-B) ">")
77 (error "Unknown mode."))))
80 ;;; Memory setup and addressing
83 (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
85 (define (make-core core-size . set-functions)
86 (let ((core-vec (make-vector core-size '()))
87 (names-vec (make-vector core-size '())))
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)
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))))
104 (print* i ":\t" ((norm-ref core-vec i) '->string))
105 (let ((n (norm-ref names-vec i)))
110 (unless (>= i core-size)
111 (vector-set! core-vec i (INITIAL-INSTR 'make-copy))
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))
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))
138 (((? integer? i) v) ((norm-ref core-vec i) v))
139 (('->addr (? integer? i)) (norm-addr i))))))
143 ;;; Programmes and task queues
146 (define (make-prog name author instrs offset)
147 (list name author instrs offset))
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))
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)))))
163 (define (can-install-prog? core prog-len addr)
164 (let loop ((ptr addr)
165 (remaining prog-len))
168 (if (null? (core ptr 'name))
169 (loop (core '->addr (+ ptr 1))
173 (define (install-progs core progs)
174 (let loop ((queues '())
176 (if (null? progs-left)
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)
183 (loop queues progs-left))))))
185 (define (make-queue name ptr)
188 (define (queue-owner queue) (car queue))
189 (define (queue-ptrs queue) (cdr queue))
191 (define (queue-set-ptrs! queue ptrs)
192 (set-cdr! queue ptrs))
194 (define (dump-queues queues core)
195 (for-each (lambda (queue)
196 (print ";" (queue-owner queue))
197 (for-each (lambda (ptr)
204 (define (prog->string prog)
206 ";name\t" (prog-name prog) "\n"
207 (if (not (null? (prog-author prog)))
208 (conc ";author\t" (prog-author prog) "\n\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)))))
213 (define (dump-prog prog)
214 (print (prog->string prog)))
217 ;;; Executive function
220 (define (run-mars core queues steps-left min-queue-count)
221 (if (or (<= steps-left 0)
222 (< (length queues) min-queue-count))
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))))
229 (run-mars core remaining-queues (- steps-left 1) min-queue-count)
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))))))
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)
242 '()) ;Game over, man, game over!
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))))
249 (combine-and-store core A-ptr B-ptr modifier name +)
250 (list (core '->addr (+ ptr 1))))
252 (combine-and-store core A-ptr B-ptr modifier name -)
253 (list (core '->addr (+ ptr 1))))
255 (combine-and-store core A-ptr B-ptr modifier name *)
256 (list (core '->addr (+ ptr 1))))
260 (combine-and-store core A-ptr B-ptr modifier name quotient)
262 (list (core '->addr (+ ptr 1))))
263 ((exn arithmetic) '())))
267 (combine-and-store core A-ptr B-ptr modifier name modulo)
268 (list (core '->addr (+ ptr 1))))
269 ((exn arithmetic) '())))
271 (list (core '->addr A-ptr)))
273 (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
277 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name))
281 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
285 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
287 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
289 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
291 (list (core '->addr (+ ptr 1)) (core '->addr A-ptr)))
293 (list (core '->addr (+ ptr 1))))
295 (error "Unrecognised opcode" (core ptr 'opcode))))))
297 (define (compare-instrs core A-ptr B-ptr modifier test)
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)))
304 (test (core A-ptr 'A-num) (core B-ptr 'A-num))
305 (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
307 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
308 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
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)))
317 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
318 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
320 (define (instr-zero? core ptr modifier decrement name)
323 (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
324 (= 0 (core ptr 'A-num)))
326 (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
327 (= 0 (core ptr 'B-num)))
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))))))
336 (define (combine-and-store core A-ptr B-ptr modifier name f)
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))))
355 (define (eval-operand core mode num ptr name)
360 ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
361 ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
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))))
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))))
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)
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)
381 (error "Unrecognized mode" mode)))))))