From: plugd Date: Sun, 17 Nov 2019 23:19:22 +0000 (+0100) Subject: New implementation working. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=560b29966dfd1f0452f19793d331731dd42274a0;p=jars.git New implementation working. --- diff --git a/mars.scm b/mars.scm index 9952774..df9aab6 100644 --- a/mars.scm +++ b/mars.scm @@ -6,15 +6,9 @@ (chicken string) (chicken random) (chicken condition) - (chicken process context) + (chicken process-context) matchable) -;;; Constants -;; - -(define core-size 20) -(define max-steps 10000) - ;;; Instructions ;; @@ -37,11 +31,16 @@ (('set! 'B-num x) (set! B-num x)) (('set-from! other) (set! opcode (other 'opcode)) - (set! modifier (other 'opcode)) + (set! modifier (other 'modifier)) (set! A-mode (other 'A-mode)) (set! A-num (other 'A-num)) (set! B-mode (other 'B-mode)) (set! B-num (other 'B-num))) + (('->string) + (conc opcode + "." modifier + " " (mode->string A-mode) A-num + " " (mode->string B-mode) B-num)) (else (error "Invalid instr arguments" args))))) @@ -58,12 +57,6 @@ (else (error "Unknown mode.")))) -(define (instr->string instr) - (conc opcode - "." modifier - " " (mode->string A-mode) A-num - " " (mode->string B-mode) B-num)) - (define initial-instruction (make-instr 'DAT 'F 'immediate 0 'immediate 0)) @@ -76,7 +69,7 @@ (names-vec (make-vector core-size '()))) (let loop ((i 0)) (unless (>= i core-size) - (vector-set! core-vec i (initial-instr 'copy)) + (vector-set! core-vec i (initial-instr 'make-copy)) (loop (+ i 1)))) (lambda args (match args @@ -89,16 +82,17 @@ ((i 'set! v x n) ((vector-ref core-vec i) 'set! v x) (vector-set! names-vec i n)) - ((i 'name) (vector-ref names i)) + ((i 'name) (vector-ref names-vec i)) ((i v) ((vector-ref core-vec i) v)) (('dump) (let loop ((i 0)) (unless (>= i core-size) - (print* i ":\t") + (print* i ":\t" ((vector-ref core-vec i) '->string)) (let ((n (vector-ref names-vec i))) (unless (null? n) (print* "\t;" n))) - (print)))))))) + (print) + (loop (+ i 1))))))))) (define (addr+ . args) (foldl (lambda (a b) @@ -121,8 +115,8 @@ (unless (null? instrs) (core ptr 'set-from-instr! (car instrs) (prog-name prog)) (loop (addr+ ptr 1) (cdr instrs)))) - (make-player (prog-name prog) - (addr+ addr (prog-offset prog)))) + (make-queue (prog-name prog) + (addr+ addr (prog-offset prog)))) (define (can-install-prog? core prog-len addr) (let loop ((ptr addr) @@ -135,21 +129,21 @@ #f)))) (define (install-progs core progs) - (let loop ((players '()) + (let loop ((queues '()) (progs-left progs)) (if (null? progs-left) - players + queues (let ((addr (pseudo-random-integer core-size)) (prog (car progs-left))) (if (can-install-prog? core (length (prog-instrs prog)) addr) - (loop (cons (install-prog core prog addr) players) + (loop (cons (install-prog core prog addr) queues) (cdr progs-left)) - (loop players progs-left)))))) + (loop queues progs-left)))))) (define (make-queue name ptr) (list name ptr)) -(define (queue-owner queue) (car player)) +(define (queue-owner queue) (car queue)) (define (queue-ptrs queue) (cdr queue)) (define (queue-set-ptrs! queue ptrs) @@ -166,13 +160,13 @@ (else (let* ((queue (car queues)) (remaining-queues (cdr queues)) - (ptrs (queue-ptrs queues)) + (ptrs (queue-ptrs queue)) (new-ptrs (execute-instr core (car ptrs) (queue-owner queue)))) (if (null? new-ptrs) - (run other-players (- steps-left 1)) + (run remaining-queues (- steps-left 1)) (begin - (player-set-ptrs! player (append (cdr ptrs) new-ptrs)) - (run (append other-players (list player)) (- steps-left 1)))))))) + (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs)) + (run core (append remaining-queues (list queue)) (- steps-left 1)))))))) (define (execute-instr core ptr name) (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name)) @@ -218,71 +212,68 @@ ((JMP) (list (addr+ ptr (core A-ptr 'A-num)))) ((JMZ) - (list (addr+ ptr (if (instr-zero? B-ptr modifier #f) - ((core-get A-ptr) 'A-num) + (list (addr+ ptr (if (instr-zero? B-ptr modifier #f name) + (core A-ptr 'A-num) 1)))) ((JMN) - (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f)) - ((core-get A-ptr) 'A-num) + (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #f name)) + (core A-ptr 'A-num) 1)))) ((DJN) - (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t)) - ((core-get A-ptr) 'A-num) + (list (addr+ ptr (if (not (instr-zero? B-ptr modifier #t name)) + (core A-ptr 'A-num) 1)))) ((SEQ CMP) - (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 2 1)))) + (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1)))) ((SNE) - (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier =) 1 2)))) + (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 1 2)))) ((SLT) - (list (addr+ ptr (if (compare-instrs A-ptr B-ptr modifier <) 2 1)))) + (list (addr+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1)))) ((SPL) - (list (addr+ ptr 1) (addr+ ptr ((core-get A-ptr) 'A-num)))) + (list (addr+ ptr 1) (addr+ ptr (core A-ptr 'A-num)))) ((NOP) (list (addr+ ptr 1))) (else (error "Unrecognised opcode" (instr 'opcode)))))) -(define (compare-instrs A-ptr B-ptr modifier test) - (let ((A-instr (core-get A-ptr)) - (B-instr (core-get B-ptr))) - (case modifier - ((A) (test (A-instr 'A-num) (B-instr 'A-num))) - ((B) (test (A-instr 'B-num) (B-instr 'B-num))) - ((AB) (test (A-instr 'A-num) (B-instr 'B-num))) - ((BA) (test (A-instr 'B-num) (B-instr 'A-num))) - ((F) (and - (test (A-instr 'A-num) (B-instr 'A-num)) - (test (A-instr 'B-num) (B-instr 'B-num)))) - ((X) (and - (test (A-instr 'A-num) (B-instr 'B-num)) - (test (A-instr 'B-num) (B-instr 'A-num)))) - ((I) (and - (if (eq? test =) - (and - (eq? (A-instr 'opcode) (B-instr 'opcode)) - (eq? (A-instr 'modifier) (B-instr 'modifier)) - (eq? (A-instr 'A-mode) (B-instr 'B-mode)) - (eq? (A-instr 'B-mode) (B-instr 'A-mode))) - #t) - (test (A-instr 'A-num) (B-instr 'B-num)) - (test (A-instr 'B-num) (B-instr 'A-num))))))) - -(define (instr-zero? ptr modifier decrement) - (let ((instr (core-get ptr))) - (case modifier - ((A AB) - (if decrement (instr 'set-A-num! (addr+ (instr 'A-num) -1))) - (= 0 (instr 'A-num))) - ((A AB) - (if decrement (instr 'set-B-num! (addr+ (instr 'B-num) -1))) - (= 0 (instr 'B-num))) - ((X I F) - (if decrement - (begin - (instr 'set-A-num! (addr+ (instr 'A-num) -1)) - (instr 'set-B-num! (addr+ (instr 'B-num) -1)))) - (and (= 0 (instr 'A-num)) - (= 0 (instr 'B-num))))))) +(define (compare-instrs core A-ptr B-ptr modifier test) + (case modifier + ((A) (test (core A-ptr 'A-num) (core B-ptr 'A-num))) + ((B) (test (core A-ptr 'B-num) (core B-ptr 'B-num))) + ((AB) (test (core A-ptr 'A-num) (core B-ptr 'B-num))) + ((BA) (test (core A-ptr 'B-num) (core B-ptr 'A-num))) + ((F) (and + (test (core A-ptr 'A-num) (core B-ptr 'A-num)) + (test (core A-ptr 'B-num) (core B-ptr 'B-num)))) + ((X) (and + (test (core A-ptr 'A-num) (core B-ptr 'B-num)) + (test (core A-ptr 'B-num) (core B-ptr 'A-num)))) + ((I) (and + (if (eq? test =) + (and + (eq? (core A-ptr 'opcode) (core B-ptr 'opcode)) + (eq? (core A-ptr 'modifier) (core B-ptr 'modifier)) + (eq? (core A-ptr 'A-mode) (core B-ptr 'B-mode)) + (eq? (core A-ptr 'B-mode) (core B-ptr 'A-mode))) + #t) + (test (core A-ptr 'A-num) (core B-ptr 'B-num)) + (test (core A-ptr 'B-num) (core B-ptr 'A-num)))))) + +(define (instr-zero? core ptr modifier decrement name) + (case modifier + ((A AB) + (if decrement (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name)) + (= 0 (core ptr 'A-num))) + ((A AB) + (if decrement (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name)) + (= 0 (core ptr 'B-num))) + ((X I F) + (if decrement + (begin + (core ptr 'set! 'A-num (addr+ (core ptr 'A-num) -1) name) + (core ptr 'set! 'B-num (addr+ (core ptr 'B-num) -1) name))) + (and (= 0 (core ptr 'A-num)) + (= 0 (core ptr 'B-num)))))) (define (combine-and-store core A-ptr B-ptr modifier name f) (case modifier @@ -338,25 +329,23 @@ (define addressing-test (make-prog 'at (list - (make-instr 'DAT 'F 'immediate 42 'immediate 53 'at) - (make-instr 'DAT 'F 'immediate 123 'immediate 256 'at) - (make-instr 'MOV 'A 'indirect-B 4 'direct 7 'at) - (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) - (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) - (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) - (make-instr 'DAT 'F 'immediate -5 'immediate -6 'at)) 2)) + (make-instr 'DAT 'F 'immediate 42 'immediate 53) + (make-instr 'DAT 'F 'immediate 123 'immediate 256) + (make-instr 'MOV 'A 'indirect-B 4 'direct 7) + (make-instr 'NOP 'I 'immediate 0 'immediate 0) + (make-instr 'NOP 'I 'immediate 0 'immediate 0) + (make-instr 'NOP 'I 'immediate 0 'immediate 0) + (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2)) (define imp - (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1 'imp)) 0)) + (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0)) (define dwarf (make-prog 'dwarf (list - (make-instr 'DAT 'F 'immediate 0 'immediate -1 'dwarf) - (make-instr 'ADD 'AB 'immediate 5 'direct -1 'dwarf) - (make-instr 'MOV 'I 'direct -2 'indirect-B -2 'dwarf) - (make-instr 'JMP 'I 'immediate -2 'immediate 0 'dwarf)) 1)) - -(initialize-core) -(define players (install-progs (list dwarf imp))) + (make-instr 'DAT 'F 'immediate 0 'immediate -1) + (make-instr 'ADD 'AB 'immediate 5 'direct -1) + (make-instr 'MOV 'I 'direct -2 'indirect-B -2) + (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1)) -(dump-core) +(define core (make-core 20 (make-instr 'DAT 'F 'immediate 0 'immediate 0))) +(define queues (install-progs core (list dwarf imp)))