2 ;;; An implementation of the Memory Array Redcode Simulator (MARS)
27 (chicken process-context)
34 (define (make-instr opcode modifier A-mode A-num B-mode B-num)
38 (('modifier) modifier)
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))
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)))
60 "\t" (mode->string A-mode) A-num
61 ", " (mode->string B-mode) B-num))
63 (error "Invalid instr arguments" args)))))
65 (define (mode->string mode)
71 ((pre-indirect-A) "{")
72 ((pre-indirect-B) "<")
73 ((post-indirect-A) "}")
74 ((post-indirect-B) ">")
76 (error "Unknown mode."))))
79 ;;; Memory setup and addressing
82 (define INITIAL-INSTR (make-instr 'DAT 'F 'immediate 0 'immediate 0))
84 (define (make-core core-size . set-functions)
85 (let ((core-vec (make-vector core-size '()))
86 (names-vec (make-vector core-size '())))
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)
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))))
103 (print* i ":\t" ((norm-ref core-vec i) '->string))
104 (let ((n (norm-ref names-vec i)))
109 (unless (>= i core-size)
110 (vector-set! core-vec i (INITIAL-INSTR 'make-copy))
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))
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))
138 (('size) core-size)))))
141 ;;; Programmes and task queues
144 (define (make-prog name author instrs offset)
145 (list name author instrs offset))
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))
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)))))
161 (define (can-install-prog? core prog-len addr)
162 (let loop ((ptr addr)
163 (remaining prog-len))
166 (if (null? (core ptr 'name))
167 (loop (core '->addr (+ ptr 1))
171 (define (install-progs core progs)
172 (let loop ((queues '())
174 (if (null? progs-left)
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)
181 (loop queues progs-left))))))
183 (define (make-queue name ptr)
186 (define (queue-owner queue) (car queue))
187 (define (queue-ptrs queue) (cdr queue))
189 (define (queue-set-ptrs! queue ptrs)
190 (set-cdr! queue ptrs))
192 (define (dump-queue queue core)
193 (let loop ((ptrs (queue-ptrs queue)))
195 (core 'dump (car ptrs))
199 (define (prog->string prog)
201 ";name\t" (prog-name prog) "\n"
202 (if (not (null? (prog-author prog)))
203 (conc ";author\t" (prog-author prog) "\n\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)))))
208 (define (dump-prog prog)
209 (print (prog->string prog)))
212 ;;; Executive function
215 (define (run-mars core queues steps-left)
216 (if (or (<= steps-left 0)
218 (= (length queues) 1))
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))))
225 (run-mars core remaining-queues (- steps-left 1))
227 (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs))
228 (run-mars core (append remaining-queues (list queue)) (- steps-left 1)))))))
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)
237 '()) ;Game over, man, game over!
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))))
244 (combine-and-store core A-ptr B-ptr modifier name +)
245 (list (core '->addr (+ ptr 1))))
247 (combine-and-store core A-ptr B-ptr modifier name -)
248 (list (core '->addr (+ ptr 1))))
250 (combine-and-store core A-ptr B-ptr modifier name *)
251 (list (core '->addr (+ ptr 1))))
255 (combine-and-store core A-ptr B-ptr modifier name quotient)
257 (list (core '->addr (+ ptr 1))))
258 ((exn arithmetic) '())))
262 (combine-and-store core A-ptr B-ptr modifier name modulo)
263 (list (core '->addr (+ ptr 1))))
264 ((exn arithmetic) '())))
266 (list (core '->addr A-ptr)))
268 (list (core '->addr (if (instr-zero? core B-ptr modifier #f name)
272 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #f name))
276 (list (core '->addr (if (not (instr-zero? core B-ptr modifier #t name))
280 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))))
282 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))))
284 (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))))
286 (list (core '->addr (+ ptr 1) (core '->addr A-ptr))))
288 (list (core '->addr (+ ptr 1))))
290 (error "Unrecognised opcode" (core ptr 'opcode))))))
292 (define (compare-instrs core A-ptr B-ptr modifier test)
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)))
299 (test (core A-ptr 'A-num) (core B-ptr 'A-num))
300 (test (core A-ptr 'B-num) (core B-ptr 'B-num))))
302 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
303 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))
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)))
312 (test (core A-ptr 'A-num) (core B-ptr 'B-num))
313 (test (core A-ptr 'B-num) (core B-ptr 'A-num))))))
315 (define (instr-zero? core ptr modifier decrement name)
318 (if decrement (core ptr 'set! 'A-num (- (core ptr 'A-num) 1) name))
319 (= 0 (core ptr 'A-num)))
321 (if decrement (core ptr 'set! 'B-num (- (core ptr 'B-num) 1) name))
322 (= 0 (core ptr 'B-num)))
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))))))
331 (define (combine-and-store core A-ptr B-ptr modifier name f)
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))))
350 (define (eval-operand core mode num ptr name)
355 ((indirect-A) (+ num (core (+ ptr num) 'A-num)))
356 ((indirect-B) (+ num (core (+ ptr num) 'B-num)))
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))))
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))))
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)
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)
376 (error "Unrecognized mode" mode)))))))