www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

vm.lisp (8457B)

      1 (defun make-vm (size &optional debug)
      2   (cons (make-array size :initial-element 0)
      3 	`(;; Registres généraux.
      4 	  (R0 . 0)
      5 	  (R1 . 0)
      6 	  (R2 . 0)
      7 	  ;; Base de la pile.
      8 	  (BP . 0)
      9 	  ;; Sommet de la pile.
     10 	  (SP . 0)
     11 	  ;; Sommet du cadre de la pile
     12 	  (FP . 0)
     13 	  ;; Pointeur de code : fin de la mémoire.
     14 	  (PC . ,(- size 1))
     15 	  ;; registres booléens = faux (nil).
     16 	  (PP . nil)
     17 	  (EQ . nil)
     18 	  (PG . nil)
     19 	  ;; Quand HALT passe à t, on arrête la machine.
     20 	  (HALT . nil)
     21 	  ;; Sert uniquement pour le debug
     22 	  (DEBUG . ,debug))))
     23 
     24 (defun get-memory (vm index)
     25   (aref (car vm) index))
     26 (defun set-memory (vm index value)
     27   (setf (aref (car vm) index) value))
     28 (defun get-register-list (vm)
     29   (mapcar #'car (cdr vm)))
     30 (defun get-register (vm reg)
     31   (cdr (assoc reg (cdr vm))))
     32 (defun set-register (vm reg value)
     33   (setf (cdr (assoc reg (cdr vm))) value))
     34 (defun size-memory (vm)
     35   (length (car vm)))
     36 (defun get-debug-mode (vm)
     37   (cdr (assoc 'debug (cdr vm))))
     38 
     39 ;; TODO : Reste a ajouter la resolution d'etiquette
     40 (defun load-asm (asm &optional (stack-size 100) (debug nil))
     41   (let ((vm (make-vm (+ (length asm) stack-size) debug))
     42         (size-vm (+ (length asm) stack-size)))
     43     (labels ((load-asm-rec (vm index asm debug)
     44                            (if (endp asm)
     45                                vm
     46                              (progn (set-memory vm index (car asm))
     47                                     (load-asm-rec vm (- index 1) (cdr asm) debug)))))
     48       (load-asm-rec vm (- size-vm 1) asm debug))))
     49 
     50 ;;TODO : Rajouter une fonction resolve pour resoudre les differents modes d'adresssage.
     51 ;; TODO : Penser a ajouter une table des opcodes
     52 
     53 (defvar *table-operateurs*
     54   '(load store move add sub mult div incr decr push pop
     55     jmp jsr rtn cmp jeq jpg jpp jpe jge jne nop halt))
     56 
     57 (defvar *table-modes-adressage*
     58   '(constant direct registre indexé indirect indirect-registre indirect-indexé))
     59 
     60 ;; Fonctions de manipulation de bits :
     61 ;; http://psg.com/~dlamkins/sl/chapter18.html
     62 ;;   (integer-length n) ≡ ⎡log₂(n)⎤
     63 ;;   (ash n décalage) = décalage binaire à gauche (ou droite si négatif)
     64 ;;   (logior a b) = ou binaire de a et b.
     65 
     66 (defun position1 (x l) (+ 1 (position x l)))
     67 
     68 ;; TODO : faire une fonction (append-bits n1 size2 n2 size3 n3 ... sizen nn)
     69 
     70 (defun append-bits (&optional (n1 0) &rest rest)
     71   (if (endp rest)
     72       n1
     73       (apply #'append-bits
     74              (logior (ash n1 (car rest))
     75                      (cadr rest))
     76              (cddr rest))))
     77 
     78 (defvar *nb-operateurs* (length *table-operateurs*))
     79 (defvar *nb-modes-adressage* (length *table-modes-adressage*))
     80 (defvar *nb-opcode-bytes*
     81   (ceiling (/ (+ (integer-length (+ 1 *nb-operateurs*))
     82                  (* 2
     83                     (integer-length (+ 1 *nb-modes-adressage*))))
     84               ;; On divise par 8 car 8 bits dans un byte.
     85               8)))
     86 
     87 (defun isn-decode (opcode)
     88   opcode)
     89 
     90 ;; Instruction est une liste
     91 ;; '(operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2)
     92 ;; Si l'instruction ne prend qu'un (ou zéro) paramètre, les champs
     93 ;; correspondants sont mis à nil.
     94 
     95 (defun isn-encode (instruction)
     96   (loop
     97      for (operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2) = instruction
     98      return (list (append-bits (position1 operateur *table-operateurs*)
     99                                *nb-modes-adressage*
    100                                (position1 mode-adressage-1 *table-modes-adressage*)
    101                                *nb-modes-adressage*
    102                                (position1 mode-adressage-2 *table-modes-adressage*))
    103                   (if (eq mode-adressage-1 'registre)
    104                       (position1 valeur-1 (get-register-list (make-vm 1)))
    105                       valeur-1)
    106                   (if (eq mode-adressage-2 'registre)
    107                       (position1 valeur-2 (get-register-list (make-vm 1)))
    108                       valeur-2))))
    109 
    110 (defun dump-vm (vm)
    111   (dotimes (i (size-memory vm))
    112     (let ((val (get-memory vm i)))
    113       (format T "~&~8,'0x ~2,'0x ~3d ~a" i val val (isn-decode val))))
    114     (mapcar (lambda (reg)
    115               (let ((val (get-register vm reg)))
    116                 (format T "~&~4a ~2,'0x ~3d" (string reg) val val)))
    117             (get-register-list vm))
    118     (let ((isn (get-memory vm (get-register vm 'PC))))
    119       (format T "~&Current instruction : ~2,'0x ~a~&" isn (isn-decode isn))))
    120 
    121 (defun ISN-LOAD (vm address register)
    122   (set-register vm register (get-memory vm address)))
    123 
    124 (defun ISN-STORE (vm register address)
    125   (set-memory vm address (get-register vm register)))
    126 
    127 (defun ISN-MOVE (vm reg1 reg2)
    128   (set-register vm reg2 (get-register vm reg1)))
    129 
    130 (defun ISN--OP- (vm op reg1 reg2)
    131   (set-register vm reg2 (funcall op
    132                                  (get-register vm reg2)
    133                                  (get-register vm reg1))))
    134 
    135 (defun ISN-ADD  (vm reg1 reg2) (ISN--OP- vm #'+ reg1 reg2))
    136 (defun ISN-SUB  (vm reg1 reg2) (ISN--OP- vm #'- reg1 reg2))
    137 (defun ISN-MULT (vm reg1 reg2) (ISN--OP- vm #'* reg1 reg2))
    138 (defun ISN-DIV  (vm reg1 reg2) (ISN--OP- vm #'/ reg1 reg2))
    139 
    140 (defun ISN-INCR (vm register)
    141   (set-register vm register (+ (get-register vm register) 1)))
    142 
    143 (defun ISN-DECR (vm register)
    144   (set-register vm register (- (get-register vm register) 1)))
    145 
    146 (defun ISN-PUSH (vm register)
    147   (ISN-INCR vm 'SP)
    148   (ISN-STORE vm register (get-register vm 'SP)))
    149 
    150 (defun ISN-POP (vm register)
    151   (ISN-LOAD vm (get-register vm 'SP) register)
    152   (ISN-DECR vm 'SP))
    153 
    154 (defun ISN-JMP (vm dst)
    155   (set-register vm 'PC (- dst 1)))
    156 
    157 (defun ISN-JSR (vm dst)
    158   (ISN-PUSH vm 'PC)
    159   (ISN-JMP vm dst))
    160 
    161 (defun ISN-RTN (vm)
    162   (ISN-POP vm 'PC))
    163 
    164 (defun ISN-CMP (vm reg1 reg2)
    165   (set-register vm 'EQ (= (get-register vm reg1) (get-register vm reg2)))
    166   (set-register vm 'PP (< (get-register vm reg1) (get-register vm reg2)))
    167   (set-register vm 'PG (> (get-register vm reg1) (get-register vm reg2))))
    168 
    169 (defun ISN--JCOND- (pp eq pg vm dst)
    170   (if (or (and eq (get-register vm 'EQ))
    171           (and pg (get-register vm 'PG))
    172           (and pp (get-register vm 'PP)))
    173       (ISN-JMP vm dst)))
    174 
    175 (defun ISN-JEQ (vm dst)
    176   (ISN--JCOND- nil t nil vm dst))
    177 
    178 (defun ISN-JPG (vm dst)
    179   (ISN--JCOND- nil nil t vm dst))
    180 
    181 (defun ISN-JPP (vm dst)
    182   (ISN--JCOND- t nil nil vm dst))
    183 
    184 (defun ISN-JPE (vm dst)
    185   (ISN--JCOND- t t nil vm dst))
    186 
    187 (defun ISN-JGE (vm dst)
    188   (ISN--JCOND- nil t t vm dst))
    189 
    190 (defun ISN-JNE (vm dst)
    191   (ISN--JCOND- t nil t vm dst))
    192 
    193 (defun ISN-NOP (vm)
    194   vm)
    195 
    196 (defun ISN-HALT (vm)
    197   (set-register vm 'HALT t))
    198 
    199 
    200 ;;Test Unitaire
    201 ;; TODO : Faire deftestvar
    202 ;; TODO : Finir le test unitaire
    203 (require 'test-unitaire "test-unitaire")
    204 (erase-tests virtual-machine)
    205 (deftestvar virtual-machine t-r0-value (+ 1 (random-test 42))) ;; r0 > 0 pour la division.
    206 (deftestvar virtual-machine t-r1-value (random-test 42))
    207 (deftestvar virtual-machine t-m-value (random-test 42))
    208 (deftestvar virtual-machine t-vm-size (+ 10 (random-test 10)))
    209 (deftestvar virtual-machine t-address (random-test t-vm-size))
    210 (deftestvar virtual-machine vm
    211   (let ((vm (make-vm t-vm-size)))
    212 	(set-register vm 'R0 t-r0-value)
    213 	(set-register vm 'R1 t-r1-value)
    214 	(set-memory vm t-address t-m-value)
    215     vm))
    216 
    217 (deftest virtual-machine
    218   (progn (ISN-LOAD vm t-address 'R0)
    219          (get-register vm 'R0))
    220   t-m-value)
    221 
    222 (deftest virtual-machine
    223   (progn (ISN-STORE vm 'R0 t-address)
    224          (get-memory vm t-address))
    225   t-r0-value)
    226 
    227 (deftest virtual-machine
    228   (progn (ISN-MOVE vm 'R0 'R1)
    229          (get-register vm 'R1))
    230   t-r0-value)
    231 
    232 (deftest virtual-machine
    233   (progn (ISN-ADD vm 'R0 'R1)
    234          (get-register vm 'R1))
    235   (+ t-r1-value t-r0-value))
    236 
    237 (deftest virtual-machine
    238   (progn (ISN-SUB vm 'R0 'R1)
    239          (get-register vm 'R1))
    240   (- t-r1-value t-r0-value))
    241 
    242 (deftest virtual-machine
    243   (progn
    244 	;; Multiplication par un petit nombre (on ne
    245 	;; gère pas d'éventuels overflows pour l'instant).
    246 	(set-register vm 'R0 2)
    247 	(ISN-MULT vm 'R0 'R1)
    248 	(get-register vm 'R1))
    249   (* 2 t-r1-value))
    250 
    251 (deftest virtual-machine
    252   (progn (ISN-DIV vm 'R0 'R1) ;; R0 > 0 (voir t-r0-value ci-dessus).
    253          (get-register vm 'R1))
    254   (/ t-r1-value t-r0-value))
    255 
    256 (deftest virtual-machine
    257   (progn (ISN-INCR vm 'R1)
    258          (get-register vm 'R1))
    259   (+ t-r1-value 1))
    260 
    261 (deftest virtual-machine
    262   (progn (ISN-DECR vm 'R0) ;; R0 > 0 (on ne gère pas les négatifs)
    263          (get-register vm 'R0))
    264   (- t-r0-value 1))
    265 
    266 (deftest virtual-machine
    267   (progn (ISN-PUSH vm 'R1)
    268          (get-memory vm (get-register vm 'SP)))
    269   t-r1-value)
    270 
    271 (provide 'vm)