home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / assembler / mipsis.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  9.6 KB  |  318 lines
  1. (herald mipsis)
  2.  
  3. (define *offset-from-template* 10)
  4.  
  5. (define-constant op/bcond 1)
  6. (define-constant op/special 0)
  7. (define-constant op/beq 4)
  8. (define-constant op/bne 5)
  9. (define-constant code/bgez 1)
  10. (define-constant code/bgezal #b010001)
  11. (define-constant code/bltz 0)
  12. (define-constant op/blez 6)
  13. (define-constant op/bgtz 7)
  14.  
  15.  
  16. (define mips/bcc
  17.   (object (lambda (bv i cc disp)
  18.         (let ((displ (branch-target-offset i disp)))
  19.           (xselect (car cc)
  20.         ((jump-op/jabs)
  21.          (i-type bv i op/bcond (rnum zero) code/bgez displ))
  22.         ((jump-op/jl)
  23.          (i-type bv i op/bcond (rnum zero) code/bgezal displ))
  24.         ((jump-op/j=)
  25.          (i-type bv i op/beq (rnum (cadr cc)) (rnum (caddr cc)) displ))
  26.         ((jump-op/jn=)
  27.          (i-type bv i op/bne (rnum (cadr cc)) (rnum (caddr cc)) displ))
  28.         ((jump-op/j<)
  29.          (i-type bv i op/bcond (rnum (cadr cc)) code/bltz displ))
  30.         ((jump-op/j<=)
  31.          (i-type bv i op/blez (rnum (cadr cc)) 0 displ))
  32.         ((jump-op/j>)
  33.          (i-type bv i op/bgtz (rnum (cadr cc)) 0 displ))
  34.         ((jump-op/j>=)
  35.          (i-type bv i op/bcond (rnum (cadr cc)) code/bgez displ)))))
  36.     ((instruction-as-string self i cc disp)
  37.      (select (car cc)
  38.        ((jump-op/jabs)
  39.     (format nil "br ~a"
  40.         (fx+ i (fx+ (fixnum-ashl (branch-target-offset i disp) 2) 4))))
  41.        ((jump-op/jl)
  42.     (format nil "brl ~a"
  43.         (fx+ i (fx+ (fixnum-ashl (branch-target-offset i disp) 2) 4))))
  44.        ((jump-op/j=)
  45.     (format nil "beq ~a,~a,~a" (rname (cadr cc)) (rname (caddr cc))
  46.         (fx+ i (fx+ (fixnum-ashl (branch-target-offset i disp) 2) 4))))
  47.        ((jump-op/jn=)
  48.     (format nil "bne ~a,~a,~a" (rname (cadr cc)) (rname (caddr cc))
  49.         (fx+ i (fx+ (fixnum-ashl (branch-target-offset i disp) 2) 4))))
  50.        (else
  51.     (format nil "b~a ~a,~a" (j->name (car cc)) (rname (cadr cc))
  52.         (fx+ i (fx+ (fixnum-ashl (branch-target-offset i disp) 2) 4))))))
  53.     ((identification self) "bcc")))
  54.  
  55. (define (j->name jump-op)
  56.   (cond ((fx>= jump-op 0)
  57.      (vref '#("a" "ne" "gtz" "gez" "gu" "cc" "pos" "vc") jump-op))
  58.     (else
  59.      (vref '#("a" "e" "lez" "ltz" "leu" "cs" "neg" "vs") (fx- 0 jump-op)))))
  60.  
  61. (define (branch-target-offset pc thing)
  62.   (cond ((fixnum? thing) (fixnum-ashr (fx- thing 4) 2))
  63.     (else
  64.      (let ((addr (address-of (cdr thing))))
  65.        (fixnum-ashr (fx- (fx- (xcase (car thing)
  66.                     ((label) addr)
  67.                     ((template) (fx+ addr 12))
  68.                     ((label+1) (fx+ addr 4)))
  69.                   pc) 4) 2)))))
  70.     
  71.     
  72. (define (normal-3op name r-code i-op)
  73.   (object (lambda (bv i s1 s2 d)
  74.         (cond ((fixnum? s1)
  75.            (r-type bv i op/special (rnum s2) (rnum s1) (rnum d) 0 r-code))
  76.           (else
  77.            (i-type bv i i-op (rnum s2) (rnum d) (get-literal i s1)))))
  78.       ((instruction-as-string self i s1 s2 d)
  79.         (cond ((fixnum? s1)
  80.            (format nil "~a ~a,~a,~a" name (rname s1) (rname s2)
  81.                (rname d)))
  82.           (else
  83.            (format nil "~a $~d,~a,~a" name (get-literal i s1)
  84.                (rname s2) (rname d)))))
  85.       ((read-registers self s1 s2 #f)
  86.        (return (if (fixnum? s1) s1 zero) s2))
  87.       ((write-register self #f #f d) d)
  88.       ((identification self) name)))
  89.  
  90. (define mips/add (normal-3op "add" #b100000 #b001000))
  91. (define mips/sub (normal-3op "sub" #b100010 0))
  92. (define mips/slt (normal-3op "slt" #b101010 #b001010))
  93. (define mips/sltu (normal-3op "sltu" #b101011 #b001011))
  94. (define risc/or (normal-3op "or"   #b100101 #b001101))
  95. (define risc/and (normal-3op "and" #b100100 #b001100))
  96. (define risc/xor (normal-3op "xor" #b100110 #b001110))
  97. (define mips/addu (normal-3op "addu" #b100001 #b001001))
  98. (define mips/subu (normal-3op "subu" #b100011 0))
  99. (define risc/add mips/addu)
  100.  
  101. (define (shifter name f-code v-code)
  102.   (object (lambda (bv i s1 s2 d)
  103.         (cond ((fixnum? s1)
  104.            (r-type bv i op/special (rnum s1) (rnum s2) (rnum d) 0 v-code))
  105.           (else
  106.            (r-type bv i op/special 0 (rnum s2) (rnum d)
  107.                (get-literal i s1) f-code))))
  108.       ((instruction-as-string self i s1 s2 d)
  109.         (cond ((fixnum? s1)
  110.            (format nil "~a ~a,~a,~a" name (rname s1) (rname s2)
  111.                (rname d)))
  112.           (else
  113.            (format nil "~a $~d,~a,~a" name (get-literal i s1)
  114.                (rname s2) (rname d)))))
  115.       ((read-registers self s1 s2 #f)
  116.        (return (if (fixnum? s1) s1 zero) s2))
  117.       ((write-register self #f #f d) d)
  118.       ((identification self) name)))
  119.  
  120. (define risc/sra (shifter "sra" #b000011 #b000111))
  121. (define risc/srl (shifter "srl" #b000010 #b000110))
  122. (define risc/sll (shifter "sll" #b000000 #b000100))
  123.  
  124. (define mips/load
  125.   (object (lambda (bv i size ro d)
  126.         (receive (base offset) (get-reg-and-offset ro)
  127.           (i-type bv i (load-op size) (rnum base) (rnum d) offset)))
  128.       ((instruction-as-string self i size ro d)
  129.        (receive (base offset) (get-reg-and-offset ro)       
  130.              (format nil "~a ~d(~a),~a" (load-op-name size) offset
  131.              (rname base) (rname d))))
  132.       ((read-registers self #f ro #f)
  133.        (return zero (cadr ro)))
  134.       ((write-register self #f #f d) d)
  135.       ((identification self) "load")))      
  136.  
  137. (define (load-op size)
  138.   (xcase size
  139.     ((l) #b100011)
  140.     ((uw) #b100101)
  141.     ((sw) #b100001)
  142.     ((ub) #b100100)
  143.     ((sb) #b100000)))
  144. (define (load-op-name size)
  145.   (xcase size
  146.     ((l) "lw")
  147.     ((uw) "lhu")
  148.     ((sw) "lh")
  149.     ((ub) "lbu")
  150.     ((sb) "lb")))
  151.  
  152. (define risc/store
  153.   (object (lambda (bv i size d ro)
  154.         (receive (base offset) (get-reg-and-offset ro)
  155.           (i-type bv i (store-op size) (rnum base) (rnum d) offset)))
  156.       ((instruction-as-string self i size d ro)
  157.        (receive (base offset) (get-reg-and-offset ro)       
  158.              (format nil "~a ~a,~d(~a)" (store-op-name size) (rname d)
  159.              offset (rname base))))
  160.       ((read-registers self #f d ro)
  161.        (return d (cadr ro)))
  162.       ((identification self) "store")))
  163.  
  164. (define (store-op size)
  165.   (xcase size
  166.     ((l) #b101011)
  167.     ((w) #b101001)
  168.     ((b) #b101000)))
  169. (define (store-op-name size)
  170.   (xcase size
  171.     ((L) "sw")
  172.     ((w) "sh")
  173.     ((b) "sb")))
  174.  
  175.  
  176. (define mips/fload
  177.   (object (lambda (bv i ro d)
  178.         (receive (base offset) (get-reg-and-offset ro)
  179.           (i-type bv i #b110001 (rnum base) d offset)))
  180.       ((instruction-as-string self i ro d)
  181.        (receive (base offset) (get-reg-and-offset ro)       
  182.              (format nil "fload ~d(~a),$f~a"  offset
  183.              (rname base) d)))
  184.       ((identification self) "fload")))
  185.  
  186. (define mips/fstore
  187.   (object (lambda (bv i d ro)
  188.         (receive (base offset) (get-reg-and-offset ro)
  189.           (i-type bv i #b111001 (rnum base) d offset)))
  190.       ((instruction-as-string self i d ro)
  191.        (receive (base offset) (get-reg-and-offset ro)       
  192.              (format nil "fstore $f~a,~d(~a)" d
  193.              offset (rname base))))
  194.       ((identification self) "fstore")))
  195.  
  196. (define-constant (16bit? x)
  197.   (and (fx<= #x-8000 x) (fx< x #x8000)))
  198.  
  199. (define-constant (u16bit? x)
  200.   (and (fx>= x 0) (fx<= x #xffff)))
  201.  
  202. (define (get-reg-and-offset ro)
  203.   (xcase (car ro)
  204.     ((reg-offset) (return (cadr ro) (enforce 16bit? (caddr ro))))))
  205.  
  206. (define (get-literal i lit)
  207.   (if (eq? (car lit) 'unsigned)
  208.       (enforce u16bit? (cdr lit))
  209.       (enforce 16bit?
  210.            (xcase (car lit)
  211.          ((lit) (cdr lit))
  212.          ((tp-offset)
  213.           (fx- (fx+ (ib-address (cdr lit)) 10) (fx+ i 4)))
  214.          ((label-offset)
  215.           (fx- (ib-address (cdr lit)) (fx+ i 4)))
  216.          ((handler-diff)
  217.           (fx- (fx+ (ib-address (cadr lit)) 12)
  218.                (ib-address (cddr lit))))))))
  219.  
  220. (define mips/lui
  221.   (object (lambda (bv i lit reg)
  222.         (i-type bv i #b001111 0 (rnum reg) (cdr lit)))
  223.     ((instruction-as-string self i lit reg)
  224.      (format nil "lui $~x,~a" (cdr lit) (rname reg)))
  225.     ((write-register self #f d) d)
  226.     ((identification self) "lui")))
  227.  
  228. (define mips/noop
  229.   (object (lambda (bv i)
  230.         (i-type bv i #b001111 0 0 0))
  231.     ((instruction-as-string self i)
  232.      "noop")))
  233.  
  234. (define mips/mult
  235.   (object (lambda (bv i sr1 sr2)
  236.         (r-type bv i op/special (rnum sr2) (rnum sr1) 0 0 #b011000))
  237.     ((read-registers self sr1 sr2)
  238.      (return sr1 sr2))
  239.     ((instruction-as-string self i sr1 sr2)
  240.      (format nil "mul ~a,~a" (rname sr1) (rname sr2)))))
  241.  
  242. (define mips/div
  243.   (object (lambda (bv i sr1 sr2)
  244.         (r-type bv i op/special (rnum sr2) (rnum sr1) 0 0 #b011010))
  245.     ((read-registers self sr1 sr2)
  246.      (return sr1 sr2))
  247.     ((instruction-as-string self i sr1 sr2)
  248.      (format nil "div ~a,~a" (rname sr1) (rname sr2)))))
  249.  
  250. (define mips/mfhi
  251.   (object (lambda (bv i sr1)
  252.         (r-type bv i op/special 0 0 (rnum sr1) 0 #b010000))
  253.     ((write-register self #f d) d)
  254.     ((instruction-as-string self i sr1)
  255.      (format nil "mfhi ~a" (rname sr1)))))
  256.  
  257. (define mips/mflo
  258.   (object (lambda (bv i sr1)
  259.         (r-type bv i op/special 0 0 (rnum sr1) 0 #b010010))
  260.     ((write-register self #f d) d)
  261.     ((instruction-as-string self i sr1)
  262.      (format nil "mflo ~a" (rname sr1)))))
  263.  
  264. (define mips/jalr
  265.   (object (lambda (bv i reg d)
  266.         (r-type bv i op/special (rnum reg) 0 (rnum d) 0 #b001001))
  267.     ((read-registers self reg #f)
  268.      (return zero reg))
  269.     ((write-register self #f d) d)
  270.     ((instruction-as-string self i reg d)
  271.      (format nil "jalr ~a,~a" (rname reg) (rname d)))))
  272.  
  273. (define mips/jr
  274.   (object (lambda (bv i reg)
  275.         (r-type bv i op/special (rnum reg) 0 0 0 #b001000))
  276.     ((read-registers self reg)
  277.      (return zero reg))
  278.     ((instruction-as-string self i reg)
  279.      (format nil "jr ~a" (rname reg)))))
  280.  
  281.   
  282. (define (rnum r)
  283.   (cond ((fx>= r 0)
  284.      (fx+ r 2))
  285.     (else
  286.      (vref '#(nil 0 24 25 16 17 18 19 20 30 31 1 21 29) (- r)))))
  287.  
  288. (define *reg-names* (make-vector *real-registers*))
  289. (set (vref *reg-names* 0) "p")
  290. (do ((i 1 (fx+ i 1)))
  291.     ((fx= i AN)
  292.      (set (vref *reg-names* AN) "an")
  293.      (set (vref *reg-names* AN+1) "an+1"))
  294.   (set (vref *reg-names* i)
  295.        (format nil "a~d" i)))
  296.  
  297. (define (rname r)
  298.   (cond ((fx>= r 0)
  299.      (vref *reg-names* r))
  300.     (else
  301.      (vref '#("nil" "zero" "eargs" "extra" "scratch" "nil" "pex" "vector"
  302.             "t" "sp" "link" "ass" "crit" "ssp")
  303.            (- r)))))
  304.  
  305.  
  306. (define lap-table (make-table 'lap-table))
  307. (define (define-lap x y)
  308.   (set (table-entry lap-table x) y))
  309.  
  310.  
  311.      
  312. (define jbr-inst mips/bcc)
  313. (define noop-inst `(,mips/noop))
  314.  
  315.  
  316.  
  317.  
  318.