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))
128 (((? integer? i) v) ((norm-ref core-vec i) v))
129 (('->addr (? integer? i)) (norm-addr i))
139 (('size) core-size)))))
142 ;;; Programmes and task queues
145 (define (make-prog name author instrs offset)
146 (list name author instrs offset))
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))
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)))))
162 (define (can-install-prog? core prog-len addr)
163 (let loop ((ptr addr)
164 (remaining prog-len))
167 (if (null? (core ptr 'name))
168 (loop (core '->addr (+ ptr 1))
172 (define (install-progs core progs)
173 (let loop ((queues '())
175 (if (null? progs-left)
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)
182 (loop queues progs-left))))))
184 (define (make-queue name ptr)
187 (define (queue-owner queue) (car queue))
188 (define (queue-ptrs queue) (cdr queue))
190 (define (queue-set-ptrs! queue ptrs)
191 (set-cdr! queue ptrs))
193 (define (dump-queue queue core)
194 (let loop ((ptrs (queue-ptrs queue)))
196 (core 'dump (car ptrs))
200 (define (prog->string prog)
202 ";name\t" (prog-name prog) "\n"
203 (if (not (null? (prog-author prog)))
204 (conc ";author\t" (prog-author prog) "\n\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)))))
209 (define (dump-prog prog)
210 (print (prog->string prog)))
213 ;;; Executive function
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))
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))))
226 (run-mars core remaining-queues (- steps-left 1))
228 (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
229 (run-mars core (append remaining-queues (list queue)) (- steps-left 1))))))))
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)
238 '()) ;Game over, man, game over!
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))))
245 (combine-and-store core A-ptr B-ptr modifier name +)
246 (list (core '->addr (+ ptr 1))))
248 (combine-and-store core A-ptr B-ptr modifier name -)
249 (list (core '->addr (+ ptr 1))))
251 (combine-and-store core A-ptr B-ptr modifier name *)
252 (list (core '->addr (+ ptr 1))))
256 (combine-and-store core A-ptr B-ptr modifier name quotient)
258 (list (core '->addr (+ ptr 1))))
259 ((exn arithmetic) '())))
263 (combine-and-store core A-ptr B-ptr modifier name modulo)
264 (list (core '->addr (+ ptr 1))))
265 ((exn arithmetic) '())))
267 (list (core '->addr A-ptr)))
269 (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
273 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name))
277 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
281 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
283 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
285 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
287 (list (core '->addr (+ ptr 1)) (core '->addr A-ptr)))
289 (list (core '->addr (+ ptr 1))))
291 (error "Unrecognised opcode" (core ptr 'opcode))))))
293 (define (compare-instrs core A-ptr B-ptr modifier test)
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)))
300 (test (core A-ptr 'A-num) (core B-ptr 'A-num))
301 (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
303 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
304 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
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)))
313 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
314 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
316 (define (instr-zero? core ptr modifier decrement name)
319 (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
320 (= 0 (core ptr 'A-num)))
322 (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
323 (= 0 (core ptr 'B-num)))
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))))))
332 (define (combine-and-store core A-ptr B-ptr modifier name f)
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))))
351 (define (eval-operand core mode num ptr name)
356 ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
357 ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
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))))
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))))
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)
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)
377 (error "Unrecognized mode" mode)))))))