home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / assembler / spis.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  12.4 KB  |  412 lines
  1. (herald spis)
  2.  
  3. (define *offset-from-template* 10)
  4.  
  5. (define sparc/bcc
  6.   (object (lambda (bv i cc disp)
  7.         (let ((displ (branch-target-offset i disp)))
  8.           (if (neq? cc jump-op/jl)
  9.           (branch-type bv i (cc->code cc) #b010 displ)
  10.           (call-type bv i displ))))
  11.     ((instruction-as-string self i cc disp)
  12.      (if (neq? cc jump-op/jl)
  13.      (format nil "b~a ~a" (cc->string cc)
  14.          (fx+ i (fixnum-ashl (branch-target-offset i disp) 2)))
  15.      (format nil "call ~a"
  16.          (fx+ i (fixnum-ashl (branch-target-offset i disp) 2)))))
  17.     ((identification self) "bcc")))
  18.  
  19. (define jbr-a-inst
  20.   (object (lambda (bv i cc disp)
  21.         (let ((displ (branch-target-offset i disp)))
  22.           (branch-a-type bv i (cc->code cc) #b010 displ)))
  23.     ((instruction-as-string self i cc disp)
  24.      (format nil "b~a,a ~a" (cc->string cc)
  25.          (fx+ i (fixnum-ashl (branch-target-offset i disp) 2))))
  26.     ((identification self) "bcc")))
  27.  
  28.  
  29. (define (cc->string jump-op)
  30.   (cond ((fx>= jump-op 0)
  31.      (vref '#("a" "ne" "gtz" "gez" "gu" "cc" "pos" "vc") jump-op))
  32.     (else
  33.      (vref '#("a" "e" "lez" "ltz" "leu" "cs" "neg" "vs") (fx- 0 jump-op)))))
  34.  
  35. (define (cc->code jump-op)
  36.   (cond ((fx>= jump-op 0)
  37.      (vref '#(8 9 10 11 12 13 14 15) jump-op))
  38.     (else
  39.      (vref '#(8 1 2 3 4 5 6 7) (fx- 0 jump-op)))))
  40.  
  41. (define (branch-target-offset pc thing)
  42.   (cond ((fixnum? thing) (fixnum-ashr thing  2))
  43.     (else
  44.      (let ((addr (address-of (cdr thing))))
  45.        (fixnum-ashr (fx- (xcase (car thing)
  46.                     ((label) addr)
  47.                     ((template) (fx+ addr 12))
  48.                     ((label+1) (fx+ addr 4)))
  49.                   pc) 2)))))
  50.     
  51.     
  52. (define (normal-3op name op3)
  53.   (object (lambda (bv i s1 s2 d)
  54.         (cond ((atom? s1)
  55.            (3-reg-format bv i op3 (rnum s2) (rnum s1) (rnum d)))
  56.           (else
  57.            (imm-format bv i op3 (rnum s2) (rnum d) (get-literal i s1)))))
  58.       ((instruction-as-string self i s1 s2 d)
  59.         (cond ((atom? s1)
  60.            (format nil "~a ~a,~a,~a" name (rname s1) (rname s2)
  61.                (rname d)))
  62.           (else
  63.            (format nil "~a $~d,~a,~a" name (get-literal i s1)
  64.                (rname s2) (rname d)))))
  65.       ((identification self) name)))
  66.  
  67. (define risc/add (normal-3op "add" #b010000))
  68. (define risc/sub (normal-3op "sub" #b010100))
  69. (define risc/or (normal-3op "or"   #b010010))
  70. (define risc/and (normal-3op "and" #b010001))
  71. (define risc/xor (normal-3op "xor" #b010011))
  72. (define risc/sra (normal-3op "sra" #b100111))
  73. (define risc/srl (normal-3op "srl" #b100110))
  74. (define risc/sll (normal-3op "sll" #b100101))
  75. (define sparc/save (normal-3op "save" #b111100))
  76. (define sparc/restore (normal-3op "restore" #b111101))
  77. (define sparc/iflush (normal-3op "iflush" #b111011))
  78.  
  79. (define sparc/jmpl
  80.   (object (lambda (bv i ro d)
  81.         (cond ((eq? (car ro) 'reg-reg)
  82.            (3-reg-format bv i #b111000 (rnum (cadr ro))
  83.                  (rnum (caddr ro)) (rnum d)))
  84.           (else
  85.            (receive (base offset) (get-reg-and-offset ro)
  86.                 (imm-format bv i #b111000 (rnum base) (rnum d) offset)))))
  87.       ((instruction-as-string self i ro d)
  88.        (cond ((eq? (car ro) 'reg-reg)
  89.           (format nil "jmpl (~a:~a),~a"
  90.               (rname (cadr ro))
  91.               (rname (caddr ro)) (rname d)))
  92.          (else
  93.           (receive (base offset) (get-reg-and-offset ro)       
  94.                (format nil "jmpl ~d(~a),~a"  offset
  95.                    (rname base) (rname d))))))
  96.       ((identification self) "jmpl")))
  97.  
  98. (define risc/load
  99.   (object (lambda (bv i size ro d)
  100.         (receive (base offset) (get-reg-and-offset ro)
  101.           (load-store-type bv i (load-op size) (rnum base) (rnum d) offset)))
  102.       ((instruction-as-string self i size ro d)
  103.        (receive (base offset) (get-reg-and-offset ro)       
  104.              (format nil "~a ~d(~a),~a" (load-op-name size) offset
  105.              (rname base) (rname d))))
  106.       ((identification self) "load")))      
  107.  
  108. (define (load-op size)
  109.   (xcase size
  110.     ((l) #b000000)
  111.     ((uw) #b000010)
  112.     ((sw) #b001010)
  113.     ((ub) #b000001)
  114.     ((sb) #b001001)
  115.     ((d) #b000011)))
  116. (define (load-op-name size)
  117.   (xcase size
  118.     ((l) "ld")
  119.     ((uw) "lduh")
  120.     ((sw) "ldsh")
  121.     ((ub) "ldub")
  122.     ((sb) "ldsb")
  123.     ((d) "ldd")))
  124.  
  125. (define risc/store
  126.   (object (lambda (bv i size d ro)
  127.         (receive (base offset) (get-reg-and-offset ro)
  128.           (load-store-type bv i (store-op size) (rnum base) (rnum d) offset)))
  129.       ((instruction-as-string self i size d ro)
  130.        (receive (base offset) (get-reg-and-offset ro)       
  131.              (format nil "~a ~a,~d(~a)" (store-op-name size) (rname d)
  132.              offset (rname base))))
  133.       ((identification self) "store")))
  134.  
  135. (define (store-op size)
  136.   (xcase size
  137.     ((l) #b000100)
  138.     ((w) #b000110)
  139.     ((b) #b000101)
  140.     ((d) #b000111)))
  141. (define (store-op-name size)
  142.   (xcase size
  143.     ((L) "st")
  144.     ((w) "sth")
  145.     ((b) "stb")
  146.     ((d) "std")))
  147.  
  148.  
  149. (define sparc/fload
  150.   (object (lambda (bv i ro d)
  151.         (receive (base offset) (get-reg-and-offset ro)
  152.           (load-store-type bv i #b100000 (rnum base) d offset)))
  153.       ((instruction-as-string self i ro d)
  154.        (receive (base offset) (get-reg-and-offset ro)       
  155.              (format nil "ldf ~d(~a),$f~a"  offset
  156.              (rname base) d)))
  157.       ((identification self) "fload")))
  158.  
  159. (define sparc/fstore
  160.   (object (lambda (bv i d ro)
  161.         (receive (base offset) (get-reg-and-offset ro)
  162.           (load-store-type bv i #b100100 (rnum base) d offset)))
  163.       ((instruction-as-string self i d ro)
  164.        (receive (base offset) (get-reg-and-offset ro)       
  165.              (format nil "stf $f~a,~d(~a)" d
  166.              offset (rname base))))
  167.       ((identification self) "fstore")))
  168.  
  169. (define-constant (13bit? x)
  170.   (and (fx<= #x-1000 x) (fx< x #x1000)))
  171.  
  172. (define-constant (u13bit? x)
  173.   (and (fx>= x 0) (fx<= x #x1fff)))
  174.  
  175. (define (get-reg-and-offset ro)
  176.   (xcase (car ro)
  177.     ((reg-offset) (return (cadr ro) (enforce 13bit? (caddr ro))))))
  178.  
  179. (define (get-literal i lit)
  180.   (xcase (car lit)
  181.     ((unsigned)
  182.      (enforce u13bit? (cdr lit)))
  183.     ((tp-offset)
  184.      (fixnum-logand #x3ff        ;low 10 bits!
  185.       (fx- (fx+ (ib-address (cdr lit)) 10) (fx- i 8)))) ;second instruction
  186.     ((handler-diff)
  187.      (fixnum-logand #x3ff (fx- (fx+ (ib-address (cadr lit)) 12)
  188.                    (ib-address (cddr lit)))))
  189.     ((lit) (enforce 13bit? (cdr lit)))
  190.     ((label-offset)
  191.      (enforce 13bit? (fx- (ib-address (cdr lit)) (fx- i 4))))))
  192.  
  193. (define (get-high i lit)
  194.   (xcase (car lit)
  195.     ((unsigned) (cdr lit))
  196.     ((tp-offset)
  197.      (fixnum-ashr (fx- (fx+ (ib-address (cdr lit)) 10) ;high 22 bits!
  198.                (fx- i 4)) 10)) ;first instruction
  199.     ((handler-diff)
  200.      (fixnum-ashr (fx- (fx+ (ib-address (cadr lit)) 12)
  201.                (ib-address (cddr lit))) 10))))
  202.  
  203.  
  204.  
  205. (define sparc/sethi
  206.   (object (lambda (bv i lit reg)
  207.         (branch-type bv i  (rnum reg) #b100 (get-high i lit)))
  208.     ((instruction-as-string self i lit reg)
  209.      (format nil "sethi $~x,~a" (get-high i lit) (rname reg)))
  210.     ((identification self) "sethi")))
  211.  
  212. (define sparc/noop
  213.   (object (lambda (bv i)
  214.         (branch-type bv i 0 #b100 0))
  215.     ((instruction-as-string self i)
  216.      "noop")))
  217.  
  218. #|  
  219. (define (rnum r)
  220.   (cond ((not (fixnum? r))
  221.      (cond ((assq r native-registers) => cdr)
  222.            (else (bug "bad native register ~s" r))))
  223.     ((fx< r 0)
  224.      (vref '#(nil 0 10 11 12 7 24 13 14 15) (fx- 0 r)))
  225.     ((fx< r *real-registers*)
  226.      (vref '#(1 2 3 4 5 6 8 9 16 17 18 19 20 21 22 23 25 26 27 28 29) r))))
  227. ;;;         g1g2g3g4g5g6o0o1 l0 l1 l2 l3 l4 l5 l6 l7 i1 i2 i3 i4 i5 
  228.  
  229. (define *reg-names* (make-vector *real-registers*))
  230. (set (vref *reg-names* 0) "p")
  231. (do ((i 1 (fx+ i 1)))
  232.     ((fx= i AN)
  233.      (set (vref *reg-names* AN) "an")
  234.      (set (vref *reg-names* AN+1) "an+1")
  235.      (do ((i 0 (fx+ i 1)))
  236.      ((fx= i *stack-registers*))
  237.        (set (vref *reg-names* (fx+ i S0)) (format nil "s~d" i))))
  238.     (set (vref *reg-names* i)
  239.        (format nil "a~d" i)))
  240.  
  241. (define (rname r)
  242.   (cond ((not (fixnum? r))
  243.      (cond ((assq r native-registers) => car)
  244.            (else (bug "bad native register ~s" r))))
  245.     ((fx>= r 0)
  246.      (vref *reg-names* r))
  247.     (else
  248.      (vref '#("nil" "zero" "eargs" "extra" "scratch" "nil" "pex" "vector"
  249.             "sp" "link")
  250.            (fx- 0 r)))))
  251. |#
  252.  
  253. (define (rnum r)
  254.   (cond ((fx>= r 0)
  255.      (if (fx= r an+1) 3 (fx+ r 16)))
  256.     (else
  257.      (vref '#(nil 0 9  10 13 29 11 12  2  1 15  8 31 14) (fx- 0 r)))))
  258. ;;;                  g0 o1 o2 o5 i5 o3 o4 g2 g1 o7 o0 i7 o6
  259.  
  260. (define *reg-names* (make-vector *real-registers*))
  261. (set (vref *reg-names* 0) "p")
  262. (do ((i 1 (fx+ i 1)))
  263.     ((fx= i AN)
  264.      (set (vref *reg-names* AN) "an")
  265.      (set (vref *reg-names* AN+1) "an+1"))
  266.   (set (vref *reg-names* i)
  267.        (format nil "a~d" i)))
  268.  
  269. (define (rname r)
  270.   (cond ((fx>= r 0)
  271.      (vref *reg-names* r))
  272.     (else
  273.      (vref '#("nil" "zero" "eargs" "extra" "scratch" "nil" "pex" "vector"
  274.             "t" "sp" "link" "ass" "crit" "ssp" "%fp" "%o0")
  275.            (fx- 0 r)))))
  276.  
  277. (define lap-table (make-table 'lap-table))
  278. (define (define-lap x y)
  279.   (set (table-entry lap-table x) y))
  280.  
  281.  
  282.      
  283. (define jbr-inst sparc/bcc)
  284. (define noop-inst `(,sparc/noop))
  285.  
  286.  
  287. (define (set-16 bv i val)
  288.   (set (bref bv (fx+ i 1)) (fixnum-logand #xff val))
  289.   (set (bref bv i) (fixnum-logand #xff (fixnum-ashr val 8))))
  290.  
  291. (define (set-24 bv i val)
  292.   (set (bref bv (fx+ i 2)) (fixnum-logand #xff val))
  293.   (set (bref bv (fx+ i 1)) (fixnum-logand #xff (fixnum-ashr val 8)))
  294.   (set (bref bv i) (fixnum-logand #xff (fixnum-ashr val 16))))
  295.  
  296.  
  297.  
  298. ;| annotation offsetSHI | handler offset |
  299. ;|           code vector offset          |    
  300. ;|      pointer       | nargs |?template | 
  301.  
  302. (define (template1 bv i l h)
  303.   (set-16 bv (fx+ i 2)
  304.        (if h
  305.        (fx- (address-of h) (fx+ i 10)) ;this template is at i+10
  306.        0))
  307.   (set-16 bv i
  308.        (get-template-annotation l)))
  309.  
  310. (define (template2 bv i l)
  311.   (cond ((table-entry *template-descriptors* l)
  312.      => (lambda (pair) 
  313.           (set (car pair) (fixnum-ashr (fx+ i 8) 2))))) ;longwords
  314.   (set (bref bv i) 0)
  315.   (set-24 bv (fx+ i 1) (fx+ i 8)))
  316.  
  317. (define (template3 bv i l)
  318.   (set-16 bv i (get-template-cells l))
  319.   (set (bref-8-u bv (fx+ i 2)) (get-template-nargs l))
  320.   (set (bref-8-u bv (fx+ i 3))
  321.        (if (template-nary l) (fx+ header/template 128) header/template)))
  322.        
  323. (define (stemplate1 bv i l)
  324.   (set-16 bv (fx+ i 2) 0)    ;handler offset
  325.   (set-16 bv i
  326.        (if (not l) 0 (get-template-annotation l))))
  327.  
  328. (define (stemplate3 bv i l encloser)
  329.   (set-16 bv i
  330.        (let ((n (lambda-max-temps encloser)))
  331.      (if (fx< n *real-registers*)
  332.          0
  333.          (fx+ (fx- n *real-registers*) 1))))
  334.   (set (bref-8-u bv (fx+ i 2)) (if (not l) -2 (get-template-nargs l)))
  335.   (set (bref-8-u bv (fx+ i 3))
  336.        (if (and l (template-nary l))
  337.        (fx+ header/template 128) header/template)))
  338.        
  339. (define (laptemplate3 bv i pointer nargs nary?)
  340.   (set-16 bv i pointer)
  341.   (set (bref-8-u bv (fx+ i 2)) nargs)
  342.   (set (bref-8-u bv (fx+ i 3))
  343.        (if nary? (fx+ header/template 128) header/template)))
  344.  
  345. (define (branch-type bv i cc op2 displ)
  346.   (set-16 bv i
  347.        (fx-ior (fixnum-ashl cc 9)
  348.            (fx-ior (fixnum-ashl op2 6)
  349.                (fixnum-logand #x3f
  350.                       (fixnum-ashr displ 16))))) ;high 6 of displ
  351.   (set-16 bv (fx+ i 2) displ))
  352.  
  353. (define (branch-a-type bv i cc op2 displ)
  354.   (set-16 bv i
  355.        (fx-ior (fx-ior (fixnum-ashl cc 9) (fixnum-ashl 1 13)) ;annul bit
  356.            (fx-ior (fixnum-ashl op2 6)
  357.                (fixnum-logand #x3f
  358.                       (fixnum-ashr displ 16))))) ;high 6 of displ
  359.   (set-16 bv (fx+ i 2) displ))
  360.  
  361. (define (call-type bv i displ)
  362.   (set-16 bv i
  363.        (fx-ior (fixnum-ashl 1 14)
  364.            (fixnum-logand #x3fff (fixnum-ashr displ 16)))) ;high 14 of displ
  365.   (set-16 bv (fx+ i 2) displ))
  366.   
  367. (define (imm-format bv i op3 rs1 rd displ)
  368.   (set-16 bv i
  369.        (fx-ior (fixnum-ashl 2 14)
  370.            (fx-ior (fixnum-ashl rd 9)
  371.                (fx-ior (fixnum-ashl op3 3)
  372.                    (fixnum-ashr rs1 2))))) ;high 3 of rs1
  373.   (set-16 bv (fx+ i 2)
  374.       (fx-ior (fixnum-ashl (fixnum-logand 3 rs1) 14) ;low 2 of sr1
  375.           (fx-ior (fixnum-ashl 1 13) ;i bit on
  376.               (fixnum-logand #x1fff displ)))))
  377.  
  378. (define (3-reg-format bv i op3 rs1 rs2 rd)
  379.   (set-16 bv i
  380.        (fx-ior (fixnum-ashl 2 14)
  381.            (fx-ior (fixnum-ashl rd 9)
  382.                (fx-ior (fixnum-ashl op3 3)
  383.                    (fixnum-ashr rs1 2))))) ;high 3 of rs1
  384.   (set-16 bv (fx+ i 2)
  385.       (fx-ior (fixnum-ashl (fixnum-logand 3 rs1) 14) ;low 2 of sr1
  386.           rs2)))
  387.  
  388. (define (load-store-type bv i op3 rs1 rd displ)
  389.   (set-16 bv i
  390.        (fx-ior (fixnum-ashl 3 14)
  391.            (fx-ior (fixnum-ashl rd 9)
  392.                (fx-ior (fixnum-ashl op3 3)
  393.                    (fixnum-ashr rs1 2))))) ;high 3 of rs1
  394.   (set-16 bv (fx+ i 2)
  395.       (fx-ior (fixnum-ashl (fixnum-logand 3 rs1) 14) ;low 2 of sr1
  396.           (fx-ior (fixnum-ashl 1 13) ;i bit on
  397.               (fixnum-logand #x1fff displ)))))
  398.  
  399.  
  400. (define (write-i-bytes bv i)
  401.   (let ((write-byte
  402.      (lambda (byte)
  403.        (writec (terminal-output) (digit->char (fx-ashr byte 4) 16))  
  404.        (writec (terminal-output) (digit->char (fx-and byte 15) 16)))))
  405.     (write-byte (bref-8-u bv (fx+ i 0)))
  406.     (write-byte (bref-8-u bv (fx+ i 1)))
  407.     (write-byte (bref-8-u bv (fx+ i 2)))
  408.     (write-byte (bref-8-u bv (fx+ i 3)))))
  409.  
  410.  
  411.  
  412.