Subversion Repositories igor

;;;

;;; Assembler!

;;;

(in-package #:mcasm)

(defvar *assembler-constants* (make-hash-table :test 'equal))

(defvar *assembler-labelnumbers* 0)

(defun next-labelnumber ()

  (incf *assembler-labelnumbers*))

(defstruct constant-info

  type

  name

  number)

(defun constant-info-to-string (info &key (key nil))

  (format nil "~A~A~A~A"

          (constant-info-type info)

          (if key

              "-"

              " ")

          (constant-info-name info)

          (if key ""

              (format nil " ~X" (constant-info-number info)))))

(defmacro def-const ((name number &key (type "const")) &body body)

  `(let ((info (make-constant-info :type ,type

                                   :name ',name

                                   :number ,number)))

     (setf (gethash (constant-info-to-string info :key nil) *assembler-constants*) info)

     ,@body))

(defmacro def-branch (name number)

  `(def-const (,name ,number :type "branch")

     (defparameter ,(intern (format nil "-BRANCH-~A-" name)) ,number)))

(def-branch O 1)

(def-branch C 2)

(def-branch N 4)

(def-branch Z 8)

(def-branch B 16)

(defmacro def-type (name number)

  `(def-const (,name ,number :type "type")

     (defparameter ,(intern (format nil "+TYPE-~A+" name)) ,number)))

(def-type none #x0)

(def-type int #x1)

(def-type float #x3)

(def-type cons #x4)

(def-type snoc #x5)

(def-type ptr #x6)

(def-type array #x7)

(def-type nil #x8)

(def-type t #x9)

(def-type char #xA)

(def-type symbol #xB)

(def-type function #xC)

(def-type builtin #xD)

(defparameter +n-regs+ #x400) ; number of registers

(defmacro defreg (name number)

  `(def-const (,name ,number :type "reg")

     (defparameter ,(intern (format nil "$~A" name)) ,number)))

(defmacro defmem (name number)

  `(def-const (,name ,number :type "memory")

     (defparameter ,(intern (format nil "%~A" name)) ,number)))

(defreg zero #x00)

(defreg one  #x01)

(defreg two  #x02)

(defreg s-addr #x03) ; address where an sframe has been stored

;;(defreg s-name #x04) ;; TODO do we want this?

;;(defreg s-fstack #x04)

(defreg s-condition #x04)

(defreg s-iterations #x05)

(defreg s-parent #x06)

;;(defreg e/f-addr #x07)

;;(defreg e/f-parent-addr #x08)

(defreg s-tmp  #x09)

(defreg e-tmp1 #x0A)

(defreg e-tmp2 #x0B)

(defreg e-tmp3 #x0C)

(defreg f-tmp1 #x0D)

(defreg f-tmp2 #x0E)

(defreg f-tmp3 #x0F)

;;(defreg e-addr #x09) ;; TODO remove this

(defreg e-expr #x10)

(defreg e-arg #x11)

(defreg e-result #x12)

(defreg e-phase #x13)

(defreg e-addr #x14)

;;(defreg f-addr #x15) ;; TODO remove this

(defreg f-func #x16)

(defreg f-env #x17)

;;(defreg f-estack #x18)

(defreg f-addr #x19)

(defreg alloc-addr #x20)

(defreg alloc-top #x21)

(defreg alloc-size #x22)

(defreg store-list-start #x23)

(defreg store-list-end #x24)

(defreg store-list-addr #x25)

(defreg store-list-reg #x26)

(defreg store-list-val #x27)

(defreg apply-result #x28)

(defreg apply-result-val #x29)

(defreg apply-func #x2A)

(defreg builtin-arg1 #x2B)

(defreg builtin-arg2 #x2C)

(defreg builtin-arg3 #x2D)

(defreg builtin-arg1-val #x2E)

(defreg builtin-arg2-val #x2F)

(defreg builtin-arg3-val #x30)

(defreg tmp-result #x33)

(defreg apply-argc #x34)

(defreg apply-required-argc #x35)

(defreg car #x40)

(defreg cdr #x41)

(defreg list-terminator #x42)

(defreg interrupt-tmp #x45)

(defreg params-car #x50)

(defreg args-car #x51)

(defreg apply-eval-expr #x52)

(defreg apply-eval-env #x53)

(defreg apply-apply-args #x54)

(defreg apply-apply-params #x55)

(defreg env #x56)

(defreg tmp1 #x57)

(defreg tmp2 #x58)

(defreg tmp3 #x59)

(defreg tmp4 #x5A)

(defreg fetch-args-arg-reg #x60)

(defreg fetch-args-arg #x61)

(defreg fetch-args-argval-reg #x62)

(defreg fetch-args-argval #x63)

(defreg fetch-args-arglist #x64)

(defreg io-devnr #x65)

(defreg io-new-devnr #x66)

(defreg io-mem-addr #x67)

(defreg message #x68)

(defreg message-shift #x69)

(defreg message-mask #x6A)

(defreg message-tmp1 #x6B)

(defreg message-tmp2 #x6C)

(defreg mc-stack-top #x090)

(defreg mc-stack-min #x091)

(defreg mc-stack-max #x09E)

(defreg e/f-top #x09F)

(defreg e/f-below-marker #x100)

(defreg e/f-min #x104)

(defreg e/f-min-expr #x104)

(defreg e/f-min-arg #x105)

(defreg e/f-min-result #x106)

(defreg e/f-min-phase #x107)

;; (defreg e/f-max-expr #x118)

;; (defreg e/f-max-arg #x119)

;; (defreg e/f-max-result #x11A)

;; (defreg e/f-max-phase #x11B)

;; (defreg e/f-max #x11B)

;; (defreg e/f-above-marker #x11C)

(defreg e/f-max-expr #x3F8)

(defreg e/f-max-arg #x3F9)

(defreg e/f-max-result #x3FA)

(defreg e/f-max-phase #x3FB)

(defreg e/f-max #x3FB)

(defreg e/f-above-marker #x3FC)

(defreg e/f-frame-size #x3FD)

(defreg init1                 #x3F0)

(defreg init2                 #x3F1)

(defreg init3                 #x3F2)

(defreg init-counter          #x3F3)

(defreg init-counter2         #x3F4)

(defreg init-shift1           #x3F5)

(defreg init-shift2           #x3F6)

(defreg init-char-mask        #x3F7)

(defreg init-chars-start      #x3F8)

(defreg init-symbol-addr      #x3F9)

(defreg init-symbol-str-addr  #x3FA)

(defreg init-symbol-char-addr #x3FB)

(defreg init-symbol-array     #x3FC)

;; needed variables (registers) for gc

;; register values that must be predefined

;; set these when testing gc standalone in emulator

(defreg gc-maxblocks #x70)      ;; total memory size

(defreg gc-spaces #x71)         ;; number of spaces we'll divide the memory in

(defreg gc-startofmem #x76)     ;; start of variable address space

;; registers set by evaluator before invoking gc

;; set these when testing gc standalone in emulator

(defreg gc-rootptr #x78)        ;; pointer to topmost object! hopefully

                                ;; there will be only one

;; registers set by init, keep these throughout

(defreg gc-spacesize #x72)      ;; size of each space: maxblocks / spaces

(defreg gc-sup #x73)            ;; first address beyond legal space:

                                ;; spaces * spacesize (NB: can be lower than

                                ;; maxblocks)

(defreg gc-gcspace #x74)        ;; start of gc exclusize space, sup - spacesize

;; registers used by everyone

(defreg gc-firstfree #x75)      ;; first free memory block

                                ;; (might exist already in other microcode)

;; scratch registers, can be used when gc is not running (but gc will

;; destroy them)

(defreg gc-1 #x80)              ;; temp

(defreg gc-vi #x83)

(defreg gc-t #x84)              ;; ptr-rev

(defreg gc-x #x85)              ;; ptr-rev

(defreg gc-y #x86)              ;; ptr-rev

(defreg gc-v #x87)              ;; ptr-rev

(defreg gc-followp #x88)        ;; ptr-rev

(defreg gc-cannext #x89)        ;; ptr-rev

(defreg gc-canprev #x8a)        ;; ptr-rev

(defreg gc-temp #x8b)

(defreg gc-mem #x8c)

(defreg gc-from #x84)           ;; at this stage we're no longer using

(defreg gc-to #x85)             ;; some of the above variables

(defreg gc-val #x86)

(defreg gc-temp2 #x87)

(defreg gc-baseaddr #x88)

(defreg gc-mem-limit #x7F)

;; div-variables (reusing gc-registers)

(defreg div-low #x88)

(defreg div-high #x89)

(defreg div-mid #x8a)

(defreg div-res #x8b)

(defreg div-sign #x8c)

(defreg mod-val1 #x87)

(defreg mod-val2 #x86)

(defparameter +gc-free+ #x00)

(defparameter +gc-used+ #x01)

(defparameter +gc-spaces+ #xA)

(defparameter +gc-limit+ #x1000) ; if free space is less than this, GC should be run

;; memory:

(defmem nil #x00)

(defmem t #x01)

(defmem if #x02)

(defmem quote #x03)

(defmem lambda #x04)

(defmem progn #x05)

(defparameter +first-builtin+ #x06)

(defmem cons #x06)

(defmem car #x07)

(defmem cdr #x08)

(defmem eval #x09)

(defmem apply #x0A)

(defmem type #x0B)

(defmem make-array #x0C)

(defmem array-size #x0D)

(defmem array-get #x0E)

(defmem array-set #x0F)

(defmem make-symbol #x10)

(defmem symbol-to-string #x11)

(defmem char-to-int #x12)

(defmem int-to-char #x13)

(defmem get-char #x14)

(defmem put-char #x15)

(defmem num-devices #x16)

(defmem device-type #x17)

(defmem set-address #x18)

(defmem get-address #x19)

(defmem error #x1A)

(defmem add #x1B)

(defmem sub #x1C)

(defmem mul #x1D)

(defmem div #x1E)

(defmem bitwise-and #x1F)

(defmem bitwise-or #x20)

(defmem bitwise-not #x21)

(defmem bitwise-shift #x22)

(defmem current-environment #x23)

(defmem make-eval-state #x24)

(defmem eval-partial #x25)

(defmem define #x26)

(defmem undefine #x27)

(defmem eq? #x28)

(defmem num-eq? #x29)

(defmem char-eq? #x2A)

(defmem less-than? #x2B)

(defmem mod #x2C)

(defmem set! #x2D)

(defmem set-car! #x2E)

(defmem set-cdr! #x2F)

(defmem function-data #x30)

(defmem builtin-name #x31)

(defmem device-size #x32)

(defmem device-status #x33)

(defparameter +last-builtin+ %device-status)

(defparameter +first-magic-var+ +first-builtin+)

(defparameter +last-magic-var+ +last-builtin+)

(defmem symbol-table #x3F)

(defparameter +first-phase+ #x40)

(defmem phase-eval #x40)

(defmem phase-eval-args #x41)

(defmem phase-apply #x42)

(defmem phase-eval-if #x43)

(defmem phase-initial #x44)

(defmem phase-env-lookup #x45)

(defmem phase-env-lookup-local #x46)

(defmem phase-apply-function #x47)

(defmem phase-bind-args #x48)

(defmem phase-eval-progn #x49)

(defmem phase-eval-args-top #x4A)

(defmem phase-eval-args-cdr #x4B)

(defmem phase-eval-args-cons #x4C)

(defmem phase-eval-symbol #x4D)

(defmem phase-set! #x4E)

(defparameter +last-phase+ %phase-set!)

(defmem timeout #x50)

(defmem err-invalid-phase #x51)

(defmem err-unbound-symbol #x52)

(defmem err-invalid-param-list #x53)

(defmem err-too-few-args #x54)

(defmem err-too-many-args #x55)

(defmem err-invalid-state #x56)

(defmem err-invalid-arg-list #x57)

(defmem err-type-error #x58)

(defmem err-not-a-list #x59)

(defmem err-not-a-function #x5A)

(defmem err-invalid-function #x5B)

(defmem err-malformed-form #x5C)

(defmem err-invalid-builtin #x5D)

(defmem err-invalid-array-index #x5E)

(defmem err-invalid-env #x5F)

(defmem err-not-a-pair #x60)

(defmem err-io-error #x61)

(defmem err-division-by-zero #x62)

(defmem err-overflow #x63)

(defparameter +last-symbol+ %err-overflow)

(defmem area-builtins #x100)

(defmem area-chars    #x200)

(defmem area-ints     #x280)

(defmem area-strings  #x300)

(defmem area-symlist  #xE00)

(defparameter +constant-chars+ (- %area-ints %area-chars))

(defparameter +constant-ints+ (- %area-strings %area-ints))

(defmem memory-root #xFFE)

(defmem mem-reserved-top #x1000)

(defmem boot-prog-start %mem-reserved-top)

(defparameter +memory-size+ (* 2 (* 1024 1024)))

(defmem io-mem-addr  #x3FFFF00) ; TODO too large for immediate value

(defmem io-devices        #x00)

(defmem io-curdev         #x01)

(defmem io-cli            #x02)

(defmem io-sai            #x03)

(defmem io-intrdev        #x04)

(defmem io-object         #x10)

(defmem io-addr-l         #x11)

(defmem io-addr-h         #x12)

(defmem io-size-l         #x13)

(defmem io-size-h         #x14)

(defmem io-status         #x15)

(defmem io-identification #x16)

(defmem io-irqenable      #x17)

(defparameter +dev-boot+ #x03)

(defparameter +dev-serial+ #x00)

;;; Helper functions

;; Convert a argument to the argument type

(defun argument-to-type (arg)

  (typecase arg

    (integer 'imm)

    (keyword 'label)

    (t 'other)))

;; Make the instruction

;; Only set the opcode

(defun make-inst-opcode (opcode &key (debug 0) (break 0))

  (let ((inst 0))

    (setf (ldb (byte 6 42) inst) opcode)

    (setf (ldb (byte 1 41) inst) debug)

    (setf (ldb (byte 1 40) inst) break)

    inst))

;; Parse an integer symbol and return the register number

(defun reg-to-num (reg)

  (typecase reg

    (symbol

     (parse-integer (subseq (format nil "~A" reg) 1)))

    (integer

     reg)))

(defmacro rewrite-inst-part (inst &key from size value)

  `(setf (ldb (byte ,size ,from) ,inst) ,value))

;; Make a function that returnes the binary representation of an instruction

(defmacro set-instruction ((&rest rest) &body body)

  (let ((opcodevar (gensym))

        (debugvar (gensym))

        (instvar (gensym))

        (breakvar (gensym)))

    `(lambda (,opcodevar ,@rest &key (,debugvar 0) (,breakvar 0))

       (let ((,instvar (make-inst-opcode ,opcodevar :debug ,debugvar :break ,breakvar)))

         ,@(loop for part in body

              collect (cons 'rewrite-inst-part (cons instvar part)))

         ,instvar))))

;; The different opcode formats

(defparameter +opcodeformats+

  `(

    (noarg . (() ,(set-instruction ())))

    (mem . ((r r imm) ,(set-instruction (r1 r2 imm)

                                        (:size 11 :from 29 :value (reg-to-num r1))

                                        (:size 11 :from 18 :value (reg-to-num r2))

                                        (:size 18 :from 0 :value imm))))

    (data . ((r r) ,(set-instruction (r1 r2)

                                         (:size 11 :from 29 :value (reg-to-num r1))

                                         (:size 11 :from 18 :value (reg-to-num r2)))))

    (dataimm . ((r imm) ,(set-instruction (r1 imm)

                                            (:size 11 :from 29 :value (reg-to-num r1))

                                            ;(:size 11 :from 18 :value (reg-to-num r2))

                                            (:size 29 :from 0 :value imm))))

    (onereg . ((r) ,(set-instruction (r1)

                                     (:size 11 :from 29 :value (reg-to-num r1)))))

    (alu . ((r r) ,(set-instruction (r1 r2)

                                      (:size 11 :from 29 :value (reg-to-num r1))

                                      (:size 11 :from 18 :value (reg-to-num r2)))))

    (argtype0 . ((imm) ,(set-instruction (imm)

                                         (:size 40 :from 0 :value imm))))

    (argtype1 . ((r imm) ,(set-instruction (r1 imm)

                                           (:size 11 :from 29 :value (reg-to-num r1))

                                           (:size 29 :from 0 :value imm))))

    (branch . ((r imm imm imm) ,(set-instruction (r1 mask flag addr)

                                                 (:size 11 :from 29 :value (reg-to-num r1))

                                                 (:size 8 :from 21 :value mask)

                                                 (:size 8 :from 13 :value flag)

                                                 (:size 13 :from 0 :value addr))))

    ))

;; Get the function from a format type

(defun get-format-function (format)

  (second (cdr (assoc format +opcodeformats+))))

;; Add an instruction to the list

(defun add-instruction (opcode args function)

  (setf *pre-assembly-data*

        (append

         (list (list opcode args function))

         *pre-assembly-data*)))

;; Define an instruction

;; The generated function returns a list that contains the opcode,

;; the arguments and the function that makes the bit representation.

(defmacro make-instruction (name format opcode)

  `(defun ,(intern (format nil "%~A" name)) (&rest args)

     (when (eq *assembler-state* :gather)

       (incf *assembler-position*))

     (let ((f (cdr (assoc ',format +opcodeformats+))))

       (when (not f)

         (error "Missing opcode group for ~A for instruction ~A" ',format ',name))

       (add-instruction ,opcode args f))))

;; Write a 48bit binary value to a stream

(defun write-48bit-unsigned (value s)

  (write-byte (ldb (byte 8 40) value) s)

  (write-byte (ldb (byte 8 32) value) s)

  (write-byte (ldb (byte 8 24) value) s)

  (write-byte (ldb (byte 8 16) value) s)

  (write-byte (ldb (byte 8 8) value) s)

  (write-byte (ldb (byte 8 0) value) s))

;; Assemble our instructions

(defun assemble-it (pre-assembly stream &key output-format simulator-lines)

  (let ((pre-assembly (copy-tree (reverse pre-assembly))))

    ;; Assemble and write out

    (format t "Writing out assembly~%")

    (let ((instructions (loop for a in pre-assembly

                           unless (labelp a)

                           collect (apply (second (third a)) (first a) (second a)))))

      (let ((number-of-instructions (length instructions)))

        (dolist (inst instructions)

          (cond ((eq output-format :human-readable)

                 (format stream "~12,'0X -- ~48,'0B~%" inst inst))

                ((eq output-format :simulator)

                 (format stream "~48,'0B~%" inst))

                (t

                 (write-48bit-unsigned inst stream))))

        (when simulator-lines

          (dotimes (i (- simulator-lines number-of-instructions))

            (format stream "~48,'0B~%" 0)))))))

;; Empty assembler cache

(defun reset-assembler ()

  (setf *pre-assembly-data* (list)))

;;; Setup instructions and reset the assembler

(defun setup-assembler ()

  (make-instruction nop noarg #x00)

  (make-instruction halt noarg #x01)

  ;; ALU

  (make-instruction add alu #x02)

  (make-instruction sub alu #x03)

  (make-instruction mul alu #x04)

  (make-instruction div alu #x05)

  (make-instruction and alu #x06)

  (make-instruction or alu #x07)

  (make-instruction xor alu #x08)

  (make-instruction not alu #x09)

  (make-instruction shift-l alu #x0A)

  (make-instruction mod alu #x0B)

  (make-instruction shift-r alu #x0C)

  ;; Memory

  (make-instruction load mem #x10)

  (make-instruction store mem #x11)

  ;; Branch

  (make-instruction branch branch #x16)

  ;; Status

  (make-instruction set-flag argtype1 #x17)

  (make-instruction clear-flag argtype0 #x18)

  (make-instruction get-flag argtype1 #x19)

  ;; Data

  (make-instruction get-type data #x20)

  (make-instruction set-type data #x21)

  (make-instruction set-type-imm dataimm #x22)

  (make-instruction set-datum data #x23)

  (make-instruction set-datum-imm dataimm #x24)

  (make-instruction get-gc data #x25)

  (make-instruction set-gc data #x26)

  (make-instruction set-gc-imm dataimm #x27)

  (make-instruction cpy data #x28)

  ;; Compare

  (make-instruction cmp-type data #x29)

  (make-instruction cmp-type-imm dataimm #x2A)

  (make-instruction cmp-datum data #x2B)

  (make-instruction cmp-datum-imm dataimm #x2C)

  (make-instruction cmp-gc data #x2D)

  (make-instruction cmp-gc-imm dataimm #x2E)

  (make-instruction cmp data #x2F)

  ;; Leds

  (make-instruction set-leds onereg #x3F)

  (reset-assembler)

  t)

;; Info gathering or assembling state

;; The first get labels information and so on, the second assemble correct instructions

(defvar *assembler-state*)

(defvar *assembler-labels*)

(defvar *assembler-position*)

;; Debug functions

;; Write labels

(defun write-labels (file labels)

  (format t "Writing out label information~%")

  (with-open-file (s

                   (concatenate 'string file ".labels")

                   :element-type 'character

                   :direction :output

                   :if-does-not-exist :create

                   :if-exists :supersede)

    (maphash

     (lambda (key value)

       (format s "~A ~X~%" key value))

     labels)))

;; Write constant information

(defun write-constants (file constants labels)

  (format t "Writing constant information~%")

  (with-open-file (s

                   (concatenate 'string file ".const")

                   :element-type 'character

                   :direction :output

                   :if-does-not-exist :create

                   :if-exists :supersede)

    (maphash

     (lambda (key value)

       (format s "label ~A ~X~%" key value))

     labels)

    (maphash (lambda (key value)

               (declare (ignore key))

               (format s "~A~%" (constant-info-to-string value)))

             constants)))

;; The main assembly macro

;; Adds inst-prefixes and fixes labels

(defmacro with-assembly ((outfile &key output-format simulator-lines) &body body)

  (let ((streamvar (gensym "STREAM")))

    `(let ((*assembler-labels* (make-hash-table))

           (*assembler-state* :gather)

           (*assembler-position* 0))

       (setf *assembler-labelnumbers* 0)

       ,@(loop

            for inst in (copy-tree body)

            when (not (labelp inst))

            collect (rewrite-instruction inst :gather)

            when (labelp inst)

            collect `(setf (gethash ,inst *assembler-labels*) *assembler-position*))

       (setf *assembler-labelnumbers* 0)

       (format t "We got ~D instructions~%" *assembler-position*)

       (with-open-file (,streamvar ,outfile

                                   :element-type ,(cond ((or (eq output-format :human-readable)

                                                             (eq output-format :simulator))

                                                         ''character)

                                                        (t ''unsigned-byte))

                                   :direction :output

                                   :if-does-not-exist :create

                                   :if-exists :supersede)

         (setf *assembler-state* :assemble)

         (reset-assembler)

         ,@(loop

              for inst in body

              when (not (labelp inst))

              collect (rewrite-instruction inst :assemble))

         ;; Write out assembled exectuable

         (assemble-it *pre-assembly-data* ,streamvar :output-format ,output-format :simulator-lines ,simulator-lines)

         ;; Output debug info

         (write-constants ,outfile *assembler-constants* *assembler-labels*)

         (write-labels ,outfile *assembler-labels*)))))

;;; Microcode instructions

(defmacro with-new-label ((prefix var) &body body)

  `(let ((,var (intern (format nil "~A-~A" (string-upcase ,prefix) (next-labelnumber)) (find-package "KEYWORD"))))

     ,@body))

(defmacro force-label (label)

  `(when (labelp ,label)

     (if (eq *assembler-state* :gather)

         (setf ,label 0)

         (progn

           (unless (gethash ,label *assembler-labels*)

             (error "Unknown label: ~A" ,label))

           (setf ,label (gethash ,label *assembler-labels*))))))

(defmacro with-force-label ((label) &body body)

  (if (integerp label)

      `(progn

         ,@body)

      `(let ((,label ,label))

         (force-label ,label)

         ,@body)))

(defmacro with-force-label* ((var label) &body body)

  `(let ((,var ,label))

     (force-label ,var)

     ,@body))

(defmacro %when (comparison &body body)

  `(with-new-label ("when" end)

     ,comparison

     (branchimm-false end)

     ,@body

     (make-label end)))

(defmacro %when-not (comparison &body body)

  `(with-new-label ("when" end)

     ,comparison

     (branchimm end)

     ,@body

     (make-label end)))

(defmacro when= ((r1 r2) &body body)

  `(with-new-label ("when=" end)

     (%cmp-datum ,r1 ,r2)

     (branchimm-false end)

     ,@body

     (make-label end)))

(defmacro when!= ((r1 r2) &body body)

  `(with-new-label ("when=" end)

     (%cmp-datum ,r1 ,r2)

     (branchimm end)

     ,@body

     (make-label end)))

(defun some-stuff ()

  (make-integer 3 4)

  (make-integer 4 4)

  (when= (3 4)

    (make-integer 5 4)))

;; Make a indirect register

(defun indirect-register (reg)

  (let ((i reg))

    (setf (ldb (byte 1 10) i) 1)

    i))

;; Branch

(defmacro %branch* (reg offset &rest flags)

  (let ((maskvar (gensym))

        (flagvar (gensym)))

    `(let ((,maskvar (funcall #'logior ,@(loop for flag in flags

                                            collect (intern (format nil "-BRANCH-~A-" (if (listp flag) (cadr flag) flag))))))

           (,flagvar (funcall #'logior ,@(loop for flag in flags

                                            when (not (listp flag))

                                            collect (intern (format nil "-BRANCH-~A-" flag))))))

       (%branch ,reg ,maskvar ,flagvar ,offset))))

(defun branchimm* (mask flag addr)

  (with-force-label (addr) ;; Hack to fix labels in a few places, sorry about this.

    (%branch $zero mask flag addr)))

;; Immediate branch true

(defun branchimm (addr)

  (branchimm* #x8 #x8 addr))

;; Immediate branch false

(defun branchimm-false (addr)

  (branchimm* #x8 0 addr))

;; Jmp

(defun jump (r addr)

  (with-force-label (addr)

    (%branch r 0 0 addr)))

(defun jump-imm (addr)

  (with-force-label (addr)

    (jump $zero addr)))

(defun jump-reg (r)

  (jump r 0))

(defun make-object-imm (reg type value)

  (%set-type-imm reg type)

  (%set-datum-imm reg value))

(defun make-integer (reg value)

  (make-object-imm reg +type-int+ value))

(defun %add* (d a b)

  (%cpy d a)

  (%add d b))

(defun %sub* (d a b)

  (%cpy d a)

  (%sub d b))

(defun %mul* (d a b)

  (%cpy d a)

  (%mul d b))

(defun %div* (d a b)

  (%cpy d a)

  (%div d b))

(defun %mod* (d a b)

  (%cpy d a)

  (%mod d b))

(defun %and* (d a b)

  (%cpy d a)

  (%and d b))

(defun %or* (d a b)

  (%cpy d a)

  (%or d b))

(defun %incr (reg)

  (%add reg $one))

(defun %decr (reg)

  (%sub reg $one))

(defun labeltest ()

  (let ((label (gensym "IF-")))

    (make-integer 10 #x5)

    (make-label (intern (format nil "~A" label) (find-package "KEYWORD")))))

#|

;; Another simple test function

;; Suppose to be used to define the real API the assembler will have

(defun test-set2 ()

  (with-assembly ("/tmp/microcode" :output-format :simulator :simulator-lines 100)

    (make-integer 3 4)

    (make-integer 4 4)

    (when= (3 4)

      (make-integer 5 4))

    (when!= (3 4)

      (make-integer 6 4))))

|#

;; Make microcode instruction functions

(setup-assembler)