From: plugd Date: Thu, 14 Nov 2019 23:11:30 +0000 (+0100) Subject: Drafted programme installation procedures. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=350ea79feb0815c673a4daab99046251a0142209;p=jars.git Drafted programme installation procedures. --- diff --git a/mars.scm b/mars.scm index f2e3d99..d7a0de2 100644 --- a/mars.scm +++ b/mars.scm @@ -4,6 +4,7 @@ (import (chicken io) (chicken string) + (chicken random) matchable) ;;; Constants @@ -13,44 +14,115 @@ (define max-steps 10000) -;;; Memory setup +;;; Instructions +;; + +(define ((blah x y) . args) + (match args + (('x q) (+ x q) q) + (('y q) y))) + +(define ((make-instr opcode modifier A-mode A-num B-mode B-num name) . args) + (match args + (('copy n) (make-instr opcode modifier A-mode A-num B-mode B-num n)) + (('opcode) opcode) + (('modifier) modifier) + (('A-mode) A-mode) + (('A-num) A-num) + (('B-mode) B-mode) + (('B-num) B-num) + (('name) name) + (('print) (print opcode + (if (null? modifier) "" (concat "." modifier)) + " " (mode-string A-mode) A-num + ", " (mode-string B-mode) B-num + (if (null? name) "" (concat " ; " name)))) + (('set-opcode! x n) (set! opcode x) (set! name n)) + (('set-modifier! x n) (set! modifier x) (set! name n)) + (('set-A-mode! x n) (set! A-mode x) (set! name n)) + (('set-A-num! x n) (set! A-num x) (set! name n)) + (('set-B-mode! x n) (set! B-mode x) (set! name n)) + (('set-B-num! x n) (set! B-num x) (set! name n)))) + +(define (mode-string mode) + (case mode + ((immediate) "#") + ((direct) "") + ((indirect-A "*")) + ((indirect-B "@")) + ((pre-indirect-A "{")) + ((pre-indirect-B "<")) + ((post-indirect-A "}")) + ((post-indirect-B ">")))) + +(define initial-instruction + (make-instr 'DAT '() 'immediate 0 'immediate 0 '())) + +;;; Memory setup and addressing ;; (define core (make-vector core-size '())) + +(define (initialize-core) + (let loop ((i 0)) + (unless (< i core-size) + (vector-set! core i (initial-instruction 'copy '())) + (loop (+ i 1))))) + (define (addr+ . args) (foldl (lambda (a b) (modulo (+ a b core-size) core-size)) 0 args)) -;;; Instructions +;;; Programmes ;; -(define (make-instr opcode modifier A-mode A-num B-mode B-num)) -(define (instr-opcode instr) (list-ref instr 0)) -(define (instr-modifier instr) (list-ref instr 1)) -(define (instr-A-mode instr) (list-ref instr 2)) -(define (instr-A-num instr) (list-ref instr 3)) -(define (instr-B-mode instr) (list-ref instr 4)) -(define (instr-B-num instr) (list-ref instr 5)) - - -;;; Players -;; - -(define (make-player name . ptrs) - (cons name ptrs)) - -(define (player-ptrs player) - (cdr player)) - -(define (player-name player) - (car player)) +(define (make-prog name instrs offset) + (list name instructions offset)) + +(define (prog-name prog) (list-ref prog 0)) +(define (prog-instrs prog) (list-ref prog 1)) +(define (prog-offset prog) (list-ref prog 2)) + +(define (install-prog prog addr) + (let loop ((ptr addr) + (instrs (prog-instrs prog))) + (unless (null? instrs) + (vector-set! core ptr (instr-copy (car instrs))) + (loop (addr+ ptr 1) (cdr instrs)))) + (make-player (prog-name prog) + (addr+ addr (prog-offset prog)))) + +(define (can-install-prog? prog-len addr) + (let loop ((ptr addr) + (remaining prog-len)) + (if (= remaining 0) + #t + (if ((vector-ref core ptr) 'name) + #f + (loop (addr+ ptr 1) + (- remaining 1)))))) + +(define (install-progs progs) + (let loop ((players '()) + (progs-left progs)) + (if (null? progs-left) + players + (let ((addr (pseudo-random-integer core-size)) + (prog (car progs-left))) + (if (can-install-prog? (length (prog-instrs prog)) addr) + (loop (cons (install-prog prog addr) players) + (cdr progs-left)) + (loop players progs-left)))))) + +(define (make-player name ptr) + (list name ptr)) (define (player-set-ptrs! player ptrs) - (set-cdr! player ptrs)) + (set-cdr! prog-queue ptrs)) -;;; Main loop +;;; Executive function ;; (define (run players step) @@ -91,30 +163,31 @@ ((NOP)) (else (error "Unrecognised opcode" (instr-opcode instr)))))) - + (define (eval-operand mode num ptr) - (case mode - ((immediate) 0) - ((direct) num) - ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num))))) - ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num))))) - ((pre-indirect-A) - (let ((aux-instr (vector-ref core (addr+ ptr num)))) - (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr))) - (addr+ num (instr-A-num aux-instr)))) - ((pre-indirect-B) - (let ((aux-instr (vector-ref core (addr+ ptr num)))) - (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr))) - (addr+ num (instr-B-num aux-instr)))) - ((post-indirect-A) - (let* ((aux-instr (vector-ref core (addr+ ptr num))) - (old-A-num (instr-A-num aux-instr))) - (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr))) - (addr+ num old-A-num))) - ((post-indirect-B) - (let* ((aux-instr (vector-ref core (addr+ ptr num))) - (old-B-num (instr-B-num aux-instr))) - (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr))) - (addr+ num old-B-num))) - (else - (error "Unrecognized mode" mode)))) + (addr+ ptr + (case mode + ((immediate) 0) + ((direct) num) + ((indirect-A) (addr+ num (instr-A-num (vector-ref core (addr+ ptr num))))) + ((indirect-B) (addr+ num (instr-B-num (vector-ref core (addr+ ptr num))))) + ((pre-indirect-A) + (let ((aux-instr (vector-ref core (addr+ ptr num)))) + (instr-set-A-num! aux-instr (addr+ -1 (instr-A-num aux-instr))) + (addr+ num (instr-A-num aux-instr)))) + ((pre-indirect-B) + (let ((aux-instr (vector-ref core (addr+ ptr num)))) + (instr-set-B-num! aux-instr (addr+ -1 (instr-B-num aux-instr))) + (addr+ num (instr-B-num aux-instr)))) + ((post-indirect-A) + (let* ((aux-instr (vector-ref core (addr+ ptr num))) + (old-A-num (instr-A-num aux-instr))) + (instr-set-A-num! aux-instr (addr+ 1 (instr-A-num aux-instr))) + (addr+ num old-A-num))) + ((post-indirect-B) + (let* ((aux-instr (vector-ref core (addr+ ptr num))) + (old-B-num (instr-B-num aux-instr))) + (instr-set-B-num! aux-instr (addr+ 1 (instr-B-num aux-instr))) + (addr+ num old-B-num))) + (else + (error "Unrecognized mode" mode)))))