;;
;; structures.scm - 6.001 Spring '04
;; project 6 (register machines / analyze)
;;
;; data structures for simulator & assembler (machine,code)
;;

(load-option 'format) ; use nifty format procedure
(set! *unparser-list-breadth-limit* 15) ; don't print all of lists

;;;;;;;;;;;;;;;;;;;;;;;;; machine ;;;;;;;;;;;;;;;;;;;;
;; cycle-count    - number of instructions executed
;; registers      - unnamed set of registers - places to store values
;; primitives     - set of (name proc) primitives available to code
;; stack          - save/restore stack
;; assembled-code - assembled-code, contains register name->index mapping

;; checks to ensure enough registers/stack size
;;  no code
(define (make-machine num-regs primitives stack-size)
  (cond ((< num-regs (length default-registers))
	 (error "too few registers, guaranteed!" num-regs))
	((< stack-size 0)
	 (error "stack size must be non-negative" stack-size))
	(else
	 (list 'machine
	       0                            ; 0 cycles to start
	       (make-vector num-regs #f)    ; vector of register values
	       primitives
	       (make-stack stack-size)
	       #f))))

;; selectors
(define machine-cycles second)
(define machine-registers third)
(define machine-primitives fourth)
(define machine-stack fifth)
(define machine-code sixth)

;; mutators
(define (set-machine-cycles! machine cycles)
  (set-car! (cdr machine) cycles))
(define (set-machine-code! machine code)
  (set-car! (cddddr (cdr machine)) code))

;; display
(define (display-machine-status machine)
  (format #t "Machine Status  (@ cycle ~A)~%" (machine-cycles machine))
  (if (machine-code machine)
      (display-registers (machine-registers machine)
			 (code-regs (machine-code machine))))
  (if (machine-code machine)
      (begin
	(format #t "Top of stack:~%")
	(if (get-register machine 'sp)
	    (display-stack-top (machine-stack machine)
			       (get-register machine 'sp))))))

;;;; cycles ;;;;

(define (inc-cycles machine)
  (set-machine-cycles! machine (+ 1 (machine-cycles machine))))

;;;; registers ;;;;

;; get register contents by number or name
(define (get-register machine reg)
  (if (number? reg)
      (vector-ref (machine-registers machine) reg)
      (vector-ref (machine-registers machine)
		  (index-of reg (code-regs
				 (machine-code machine))))))

;; set register contents by number or name
(define (set-register! machine reg val)
  (if (number? reg)
      (vector-set! (machine-registers machine) reg val)
      (vector-set! (machine-registers machine)
		   (index-of reg (code-regs
				  (machine-code machine)))
		   val)))

(define (num-registers machine)
  (vector-length (machine-registers machine)))

(define (display-registers regs names)
  (let loop ((names names)
	     (i 0))
    (if (not (null? names))
	(begin
	  (format #t "  ~10A ~30A~%" (car names) (vector-ref regs i))
	  (loop (cdr names) (+ i 1))))))

;;;; stack ;;;;

;; stack represented by vector, register 'sp' points to
;; next element
;; also contains a max-depth indicator
(define (make-stack size)
  (list 'stack (make-vector size #f) 0)) 

(define stack-vector second)
(define stack-max-depth third)
(define (set-max-depth! stack md)
  (set-car! (cddr stack) md))

(define (stack-size stack)
  (vector-length (stack-vector stack)))

;; push value onto stack, error if overflow
(define (stack-push machine val)
  (let ((stack (machine-stack machine))
	(sp (get-register machine 'sp)))
    (if (>= sp (stack-size stack))
	(machine-error machine "stack overflow")
	(begin
	  (vector-set! (stack-vector stack)
		       sp
		       val)
	  (set-register! machine 'sp (+ 1 sp))
	  (if (> (+ sp 1) (stack-max-depth stack))
	      (set-max-depth! stack (+ sp 1)))
	  'pushed))))

;; pop value off stack and return it, error if underflow
(define (stack-pop machine)
  (let ((sp (get-register machine 'sp)))
    (if (<= sp 0)
	(machine-error machine "stack underflow")
	(begin
	  (set-register! machine 'sp (- sp 1))
	  (vector-ref (stack-vector (machine-stack machine)) (- sp 1))))))
  
;; how many elements of stack to print
(define *stack-top-count* 5)

(define (display-stack-top stack sp)
  (if (= sp 0)
      (format #t " (empty stack)~%")
      (let loop ((sp sp)
		 (counter 0))
	(if (and (> sp 0) (< counter *stack-top-count*))
	    (begin
	      (format #t " ~3A ~30A~%" (- sp 1) (vector-ref (stack-vector stack) (- sp 1)))
	      (loop (- sp 1) (+ counter 1)))))))

;;;; machine-code ;;;;

;;lookup a name in the table of operations.  Signal error
;; if operation not in table. 
(define (lookup-prim symbol operations)
  (let ((val (assq symbol operations)))
    (if val
        (cadr val)
        (error "Unknown operator -- ASSEMBLE" symbol))))

;; load code into machine
;;  checks used register count < available regs
;;  checks used primitives all available
;;  after load, initializes pc & sp to 0
(define (load-code machine code)
  (let ((newcode
	 (if (machine-code machine)
	     (join-code (machine-code machine)
			code)
	     (join-code default-code code))))
    (if (<= (length (code-regs newcode))
	    (num-registers machine))
	(if (subset? (code-ops newcode)
		     (map car (machine-primitives machine)))
	    (begin
	      (set-machine-code! machine newcode)
	      (set-register! machine 'pc 0)
	      (set-register! machine 'sp 0)
	      'code-loaded)
	    (machine-error machine
			   "unknown primitives"
			   (code-ops newcode)))
	(machine-error machine
		       "too many registers"
		       (code-regs newcode) 
		       (num-registers machine)))))

;; sets the pc to the given label
(define (initialize-pc machine label)
  (let ((startat (lookup-label label
			       (code-label-table 
				(machine-code machine)))))
    (if startat
	(set-register! machine 'pc startat)
	(machine-error machine "bad start label" label))))

;; increment program counter
(define (inc-pc! machine)
  (set-register! machine 'pc (+ 1 (get-register machine 'pc))))

;; sets the continue register to the given label
(define (initialize-continue machine label)
  (let ((cont (lookup-label label
			    (code-label-table 
			     (machine-code machine)))))
    (if cont
	(set-register! machine 'continue cont)
	(machine-error machine "bad continue label" label))))

;; sets registers arg0,arg1,arg2,arg3 to values in list.
;;  more than 4 args is an error
(define (initialize-args machine args)
  (let loop ((args args)
	     (argnames '(arg0 arg1 arg2 arg3)))
    (cond ((null? args)
	   'done)
	  ((null? argnames)
	   (error "too many args supplied!" args))
	  (else
	   (set-register! machine
			  (car argnames)
			  (car args))
	   (loop (cdr args) (cdr argnames))))))

;; resets machine, clearing code, registers, stack, & cycle count
(define (reset-machine machine)
  (set-machine-cycles! machine 0)
  (set-max-depth! (machine-stack machine) 0)
  (vector-fill! (machine-registers machine) #f)
  (set-machine-code! machine #f))

;;;;;;;;;;;;;;; assembled-code abstraction ;;;;;;;;;;;;;;;;;;;;
;; regs is a list of register names, mapped to register numbers
;; ops is a list of operation names; checked against list supported
;;   by machine on load
;; label-table is a table of label -> offset used at runtime
;; assembled-insts is a vector of instruction
;; size is number of instructs in assembled-insts

(define (make-assembled-code regs ops label-table assembled-insts inst-count)
  (list 'assembled-code regs ops label-table assembled-insts inst-count))

;; selectors
(define code-regs second)
(define code-ops third)
(define code-label-table fourth)
(define code-insts fifth)
(define code-size sixth)

;; add a register to list, discard if duplicate
(define (code-add-reg! code newreg)
  (if (not (memq newreg (code-regs code)))
      (set-car! (cdr code) (cons newreg (code-regs code)))
      'already-there))

;; add an op to list, discard if duplicate
(define (code-add-op! code newop)
  (if (not (memq newop (code-ops code)))
      (set-car! (cddr code) (cons newop (code-ops code)))
      'already-there))

;; mutators
(define (code-set-labels! code newlabels)
  (set-car! (cdddr code) newlabels))
(define (code-set-insts! code newinsts)
  (set-car! (cddddr code) newinsts))
(define (code-set-size! code newsize)
  (set-car! (cddddr (cdr code)) newsize))

;; merge two assembled code blocks
(define (join-code code-orig code-new)
  (make-assembled-code (remove-duplicates (append (code-regs code-orig)
						  (code-regs code-new)))
		       (remove-duplicates (append (code-ops code-orig)
						  (code-ops code-new)))
		       (join-table (code-label-table code-orig)
				   (code-label-table code-new)
				   (code-size code-orig))
		       (join-instructions (code-insts code-orig)
					  (code-size code-orig)
					  (code-insts code-new)
					  (code-size code-new))
		       (+ (code-size code-orig) (code-size code-new))))

;; merge multiple code blocks
(define (join-all-code code . args)
  (reduce join-code 'impossible (cons code args)))

;; clean display of assembled code
(define (display-assembled-code code)
  (format #t "Assembled code:~%  Regs: ~A~%  Ops: ~A~%  Code-size: ~A~%  Labels:~%"
	  (code-regs code) (code-ops code) (code-size code))
  (display-label-table (code-label-table code))
  (format #t "Instructions:~%")
  (display-instructions (code-insts code) (code-size code))
  (format #t "-------------~%"))

;;;;;;;;;;;;;;;;;;;;;;;;; label-table ;;;;;;;;;;;;;;;;;;;;;;;;
;; store (label offset) pairs

(define (make-label-table)
  (list 'label-table))

;; mutate table: add (label offset) pair
(define (add-label! table label offset)
  (set-cdr! (last-pair table) (list (list label offset)))
  table)

;; lookup label return offset or #f
(define (lookup-label label table)
  (let ((val (assq label (cdr table))))
    (if val
	(cadr val)
	#f)))

;; join two label tables
(define (join-table orig-table new-table offset)
  (fold-right
   (lambda (entry table)
     (if (lookup-label (car entry) table)
	 (error "duplicate label name" (car entry))
	 (add-label! table (car entry) (+ offset (cadr entry)))))
   (list-copy orig-table) ; crazy hack to avoid mutating orig-table
   (cdr new-table)))

;; pretty print label tables
(define (display-label-table table)
  (format #t "   ~15A  ~6A~%" "Label" "Offset")
  (let loop ((entries (sort (cdr table) (lambda (x y) (< (cadr x) (cadr y))))))
    (if (not (null? entries))
	(begin
	  (format #t "   ~15A  ~6A~%" (caar entries) (cadar entries))
	  (loop (cdr entries))))))

;;;;;;;;;;;;;;;;;;;;;; assembled instructions ;;;;;;;;;;;;;;;;;;;;;;;;
;; stored as a vector for fast indexing

(define (make-assembled-instructions size)
  (make-vector (+ size 1) default-instruction))

;; retrieve instruction based on index
(define (get-instruction asm-insts i)
  (vector-ref asm-insts i))

;; insert instruction at index
(define (set-instruction! asm-insts i val)
  (vector-set! asm-insts i val))

;; merge two instruction vectors, return new vector
(define (join-instructions insts-orig size-orig insts-new size-new)
  (let ((final (make-vector (+ size-orig size-new 1) default-instruction)))
    (subvector-move-left! insts-orig 0 size-orig final 0)
    (subvector-move-left! insts-new 0 size-new final size-orig)
    final))

;; pretty print instruction vector
(define (display-instructions insts size)
  (let loop ((i 0))
    (if (< i size)
	(begin
	  (format #t " ~3A ~A~%" i (get-instruction insts i))
	  (loop (+ i 1))))))


;;;;;;;;;;;;;;;;;;;;;; defaults ;;;;;;;;;;;;;;;;;;;;;;;

;; registers that are always present
(define default-registers
  '(pc                       ; program counter
    cr                       ; condition register (set by test)
    sp                       ; stack pointer
    continue                 ; where to go next
    arg0 arg1 arg2 arg3      ; arguments
    result))                 ; return value

;; 'filler' instruction used to pad code
(define default-instruction '(halt))

;; automatically defined code
(define default-code
  (make-assembled-code
   default-registers         ; default (always present) registers
   '()                       ; no ops
   (add-label!               ; one label, pointing to the halt
    (make-label-table)
    'machine-done 0)
   (make-vector
    1 default-instruction)  ; only a (halt) inst
   1))                       ; 1 instruction

;; primitives available by default
(define standard-primitives
  `((+ ,+)
    (- ,-)
    (* ,*)
    (/ ,/)
    (inc ,inc)
    (dec ,dec)
    (= ,=)
    (< ,<)
    (> ,>)
    (zero? ,zero?)
    (cons ,cons)
    (car ,car)
    (cdr ,cdr)
    (pair? ,pair?)
    (null? ,null?)
    (list ,list)
    (eq? ,eq?)
    (symbol? ,symbol?)
    (write-line ,write-line)
    (not ,not)
    (true ,true)
    (false ,false)
    (nil ,nil)
    (make-vector ,make-vector)
    (vector-ref ,vector-ref)
    (vector-set! ,vector-set!)
    (random ,random)
    (make-matrix ,make-matrix)
    (matrix-size ,matrix-size)
    (generate-random-matrix ,generate-random-matrix)
    (generate-identity-matrix ,generate-identity-matrix)
    (print-matrix ,print-matrix)
    (matrix-ref ,matrix-ref)
    (matrix-set! ,matrix-set!)
    ))