home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / assembler / mipsas.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  10.0 KB  |  325 lines
  1. (herald marchas)
  2.  
  3. (lset *deferred-loads?* t)
  4.  
  5. (define risc/sub
  6.   (object nil
  7.     ((read-registers self r1 r2 r3)
  8.      (read-registers risc/add r1 r2 r3))
  9.     ((write-register self r1 r2 r3)
  10.      (write-register risc/add r1 r2 r3))))
  11.  
  12. (define risc/load 
  13.   (object nil
  14.     ((read-registers self l ro d)
  15.      (read-registers mips/load l ro d))
  16.     ((write-register self l ro d)
  17.      (write-register mips/load l ro d))))
  18.     
  19. (define maybe-pushfr 'maybe-pushfr)
  20. (define maybe-popfr 'maybe-popfr)
  21.  
  22. (define (emit-jump 1tag)
  23.   (cond ((and (node? 1tag)
  24.           (lambda-node? 1tag)
  25.           (eq? (lambda-strategy 1tag) strategy/heap))
  26.      (push (ib-instructions *current-ib*)
  27.            (list jbr-inst nil (list jump-op/jabs)
  28.              (cons 'template (maybe-cons-an-ib 1tag))))
  29.      (push (ib-instructions *current-ib*)
  30.            (list mips/noop nil)))
  31.     (else
  32.      (set (ib-cc *current-ib*) (list jump-op/jabs))
  33.      (let ((1next (maybe-cons-an-ib 1tag)))
  34.        (set (ib-1next *current-ib*) 1next)
  35.        (push (ib-previous 1next) *current-ib*)))))
  36.  
  37. (define (emit-branch-and-link l)
  38.   (push (ib-instructions *current-ib*)
  39.     (list jbr-inst nil (list jump-op/jl)
  40.           (cond ((fixnum? l) l)
  41.             ((and (node? l) (eq? (lambda-strategy l) strategy/heap))
  42.              (cons 'template (maybe-cons-an-ib l)))
  43.             (else
  44.              (cons 'label (maybe-cons-an-ib l)))))))
  45.  
  46. (define (emit-branch l)
  47.   (push (ib-instructions *current-ib*)
  48.     (list jbr-inst nil (list jump-op/jabs)
  49.           (cons 'label (maybe-cons-an-ib l)))))
  50.  
  51. (define (emit-avoid-jump 1tag)
  52.   (set (ib-avoid-jump? *current-ib*) '#t)
  53.   (emit-jump 1tag))
  54.  
  55. (define (emit-compare cc reg1 reg2 1tag 0tag)
  56.   (receive (cc-list inst) (branch-pseudo-op cc reg1 reg2)
  57.     (set (ib-cc *current-ib*) cc-list)
  58.     (if inst (push (ib-instructions *current-ib*) inst))
  59.     (let ((1next (maybe-cons-an-ib 1tag)))
  60.       (set (ib-1next *current-ib*) 1next)
  61.       (push (ib-previous 1next) *current-ib*))
  62.     (and 0tag
  63.      (let ((0next (maybe-cons-an-ib 0tag)))
  64.        (set (ib-0next *current-ib*) 0next)
  65.        (push (ib-previous 0next) *current-ib*)))))
  66.  
  67.  
  68. ;; Note that the slt arguments are reversed to be compatible with add etc.
  69.  
  70. (define (branch-pseudo-op cc reg1 reg2)
  71.   (xselect cc
  72.     ((jump-op/jn= jump-op/j=)
  73.      (cond ((fixnum? reg2) (return (list cc reg1 reg2) nil))
  74.         (else
  75.          (return (list cc reg1 ass-reg)
  76.              (list risc/add nil reg2 zero ass-reg)))))
  77.     ((jump-op/j<)
  78.      (cond ((eq? reg2 zero) (return (list cc reg1) nil))
  79.        ((and (eq? reg1 zero) (fixnum? reg2))
  80.         (return (list (reverse-jump-ops cc) reg2) nil))
  81.        (else
  82.         (return (list jump-op/jn= ass-reg zero)
  83.              (list mips/slt nil reg2 reg1 ass-reg)))))
  84.     ((jump-op/j>=)
  85.      (cond ((eq? reg2 zero) (return (list cc reg1) nil))
  86.        ((and (eq? reg1 zero) (fixnum? reg2)) 
  87.         (return (list (reverse-jump-ops cc) reg2) nil))
  88.        (else
  89.         (return (list jump-op/j= ass-reg zero)
  90.              (list mips/slt nil reg2 reg1 ass-reg)))))
  91.     ((jump-op/j<=)
  92.      (cond ((eq? reg2 zero) (return (list cc reg1) nil))
  93.        ((and (eq? reg1 zero) (fixnum? reg2)) 
  94.         (return (list (reverse-jump-ops cc) reg2) nil))
  95.        ((fixnum? reg2)
  96.         (return (list jump-op/j= ass-reg zero)
  97.             (list mips/slt nil reg1 reg2 ass-reg)))
  98.        (else
  99.         (return (list jump-op/jn= ass-reg zero)
  100.             (list mips/slt nil `(lit . ,(fx+ (cdr reg2) 1)) reg1 ass-reg)))))
  101.     ((jump-op/j>)
  102.      (cond ((eq? reg2 zero) (return (list cc reg1) nil))
  103.        ((and (eq? reg1 zero) (fixnum? reg2)) 
  104.         (return (list (reverse-jump-ops cc) reg2) nil))
  105.        ((fixnum? reg2)
  106.         (return (list jump-op/jn= ass-reg zero)
  107.             (list mips/slt nil reg1 reg2 ass-reg)))
  108.        (else
  109.         (return (list jump-op/j= ass-reg zero)
  110.             (list mips/slt nil `(lit . ,(fx+ (cdr reg2) 1)) reg1 ass-reg)))))
  111.     ((jump-op/uj<)
  112.      (return (list jump-op/jn= ass-reg zero)
  113.          (list mips/sltu nil reg2 reg1 ass-reg)))
  114.     ((jump-op/uj<=)
  115.      (return (list jump-op/j= ass-reg zero)
  116.          (list mips/sltu nil reg1 reg2 ass-reg)))
  117.     ((jump-op/uj>)
  118.      (return (list jump-op/jn= ass-reg zero)
  119.          (list mips/sltu nil reg1 reg2 ass-reg)))
  120.     ((jump-op/uj>=)
  121.      (return (list jump-op/j= ass-reg zero)
  122.          (list mips/sltu nil reg2 reg1 ass-reg)))))
  123.  
  124. (define (assembly-list is bv)
  125.   (do ((is is (cdr is))
  126.        (i 0 (fx+ i CELL)))
  127.       ((null? is) repl-wont-print)
  128.     (format t "~&~d:~8t" i)
  129.     (write-i-bytes bv i)
  130.     (destructure (((op comment . args) (car is)))
  131.       (format t "~20t~a~40t" (apply instruction-as-string op i args))
  132.       (if comment
  133.       (apply format t (car comment) (cdr comment))))))
  134.  
  135. (define (assemble-bits size is)
  136.   (let ((code (make-bytev size)))
  137.     (set *is* is)
  138.     (set *bits* code)
  139.     (do ((is is (cdr is))
  140.      (i 0 (fx+ i CELL)))
  141.     ((null? is)
  142.      (format *noise+terminal* "~&; assembled ~d bytes~%" size)
  143.      code)
  144.       (destructure (((op comment . args) (car is)))
  145.     (apply op code i args)))))
  146.  
  147.  
  148. (define (add-to-front block)
  149.   (cond ((or (not block) (ib-address block)))
  150.     ((fx> (length (ib-previous block)) 1)
  151.      (push *blocks-pending* block))
  152.     (else
  153.      (modify *blocks-pending* (lambda (x) (append! x (list block)))))))
  154.  
  155.  
  156. (define (linearize-code-blocks i is)
  157.   (if (null? *blocks-pending*)
  158.       (return i is)
  159.       (let ((ib (pop *blocks-pending*)))
  160.     (cond ((ib-address ib) (linearize-code-blocks i is))
  161.           (else
  162.     (set (ib-address ib) i) 
  163.     (iterate loop ((i i) (ib ib) (newis (ib-instructions ib)) (is is))
  164.       (cond ((null? newis)
  165.          (let ((0next (ib-0next ib))
  166.                (1next (ib-1next ib)))
  167.            (cond ((not 0next) 
  168.               (cond ((null? 1next)
  169.                  (linearize-code-blocks i is))
  170.                 ((and (not (ib-avoid-jump? ib))
  171.                       (any? ib-avoid-jump?
  172.                         (ib-previous 1next))
  173.                       (not (ib-address 1next)))
  174.                  (add-to-front (ib-0next 1next))
  175.                  (add-to-front (ib-1next 1next))
  176.                  (add-jump-no-return 1next i is))
  177.                 ((not (ib-address 1next))
  178.                  (set (ib-address 1next) i)
  179.                  (loop i 1next (ib-instructions 1next) is))
  180.                 (else
  181.                  (add-jump-no-return 1next i is))))
  182.              ((not (ib-address 1next))
  183.               (add-to-front 0next)
  184.               (modify (car (ib-cc ib)) reverse-branch)
  185.               (receive (i is) (add-jump 0next i is (ib-cc ib))
  186.                 (set (ib-address 1next) i)
  187.                 (loop i 1next (ib-instructions 1next) is)))
  188.              ((not (ib-address 0next))
  189.               (receive (i is) (add-jump 1next i is (ib-cc ib))
  190.                 (set (ib-address 0next) i)
  191.                             (loop i 0next (ib-instructions 0next) is)))
  192.              ((preferred-arm? 0next 1next)
  193.               (modify (car (ib-cc ib)) reverse-branch)
  194.               (receive (i is) (add-jump 0next i is (ib-cc ib))
  195.                 (add-jump-no-return 1next i is)))
  196.              (else
  197.               (receive (i is) (add-jump 1next i is (ib-cc ib))
  198.                 (add-jump-no-return 0next i is))))))
  199.         (else
  200.          (let ((inst (caar newis)))
  201.            (select (cond (*deferred-loads?* inst)
  202.                    ((eq? inst risc/load) nil)
  203.                    (else inst))
  204.            ((risc/load)
  205.             (set (caar newis) mips/load)
  206.             (if (need-to-delay? (car newis) (cdr newis))
  207.             (loop (fx+ i (fx* CELL 2)) ib (cdr newis)
  208.                   (cons noop-inst (cons (car newis) is)))
  209.             (loop (fx+ i CELL) ib (cdr newis) (cons (car newis) is))))
  210.            ((maybe-pushfr)
  211.             (receive (is incr)
  212.                      (figure-pushfr is (lambda-max-temps (caddr (car newis))))
  213.               (loop (fx+ i incr) ib (cdr newis) is)))
  214.            ((maybe-popfr)
  215.             (receive (is incr)
  216.                      (figure-popfr is (lambda-max-temps (caddr (car newis))))
  217.               (loop (fx+ i incr) ib (cdr newis) is)))
  218.            ((risc/sub)
  219.             (destructure (((op #f lit?) (car newis))) 
  220.               (cond ((not (fixnum? lit?))
  221.                  (set (car (car newis)) risc/add)
  222.                  (modify (cdr (caddr (car newis))) -))
  223.                 (else
  224.                  (set (caar newis) mips/subu)))
  225.               (loop (fx+ i CELL) ib (cdr newis) (cons (car newis) is))))
  226.            (else
  227.             (loop (fx+ i CELL) ib (cdr newis) (cons (car newis) is)))))))))))))
  228.  
  229.  
  230. (define (preferred-arm? ib1 ib2)
  231.   (let ((node1 (ib-node ib1))
  232.     (node2 (ib-node ib2)))
  233.     (and (node? node1)
  234.      (node? node2)
  235.      (fx< (lambda-trace node1) (lambda-trace node2)))))
  236.     
  237.  
  238. (define (reverse-branch cc)
  239.   (select cc
  240.     ((jump-op/jabs jump-op/jl) cc)
  241.     (else (- cc))))
  242.  
  243.  
  244. (define (figure-pushfr is n)
  245.   (cond ((fx= n 0) (return is 0))
  246.     ((fx= n 1)
  247.      (return
  248.       `((,risc/store () l ,LINK-REG (reg-offset ,SP 0))
  249.         (,risc/add () (lit . -4) ,SP ,SP)
  250.         ,@is)
  251.       (fx* CELL 2)))
  252.     (else
  253.      (let ((bump (* (fx+ (fx- n *real-registers*) 2) 4)))
  254.        (return 
  255.         `((,risc/store () l ,LINK-REG (reg-offset ,SP ,(fx- bump 4)))
  256.           (,risc/add () (lit . ,(- bump)) ,SP ,SP)
  257.         ,@is)
  258.         (fx* CELL 2))))))
  259.  
  260. (define (figure-popfr is n)
  261.   (cond ((fx= n 0) (return is 0))
  262.     ((fx= n 1)
  263.      (return
  264.       `((,risc/add () (lit . 4) ,SP ,SP)
  265.         (,mips/load () l (reg-offset ,SP 0) ,LINK-REG)
  266.         ,@is)
  267.       (fx* CELL 2)))
  268.     (else
  269.      (let ((bump (* (fx+ (fx- n *real-registers*) 2) 4)))
  270.        (return
  271.         `((,risc/add () (lit . ,bump) ,SP ,SP)
  272.           (,mips/load () l (reg-offset ,SP ,(fx- bump 4)) ,LINK-REG)
  273.         ,@is)
  274.       (fx* CELL 2))))))
  275.  
  276. (define (add-jump-no-return next i is)
  277.   (receive (i is) (add-jump next i is (cons jump-op/jabs 0))
  278.     (linearize-code-blocks i is)))
  279.  
  280. #|
  281. (define (add-jump next i is cc)
  282.   (return (fx+ i (fx* CELL 2))
  283.       (cons noop-inst
  284.         (cons (list jbr-inst nil cc (cons 'label next)) is))))
  285.  
  286. (define (need-to-delay? #f #f) '#t)
  287.  
  288. |#
  289.  
  290. (define (add-jump next i is cc)
  291.   (let ((insts (ib-instructions next)))
  292.     (cond ((or (null? insts)
  293.            (fxn= (car cc) jump-op/jabs)
  294.            (branch-instruction? (car insts)))
  295.        (return (fx+ i (fx* CELL 2))
  296.            (cons noop-inst 
  297.              (cons (list jbr-inst nil cc (cons 'label next))
  298.                    is))))
  299.       (else
  300.        (return (fx+ i (fx* CELL 2))
  301.            (cons (car insts) 
  302.              (cons (list jbr-inst nil cc (cons 'label+1 next))
  303.                    is)))))))
  304.  
  305. (define (branch-instruction? x)
  306.   (or (eq? (car x) mips/jalr)
  307.       (eq? (car x) mips/jr)
  308.       (eq? (car x) jbr-inst)
  309.       (eq? (car x) maybe-popfr)
  310.       (eq? (car x) maybe-pushfr)))
  311.  
  312. (define (need-to-delay? load rest)
  313.   (if (null? rest)
  314.       '#t
  315.       (let ((write (apply write-register mips/load (cddr load))));flush comment
  316.     (destructure (((op #f . args) (car rest)))
  317.       (select  op
  318.         ((maybe-pushfr maybe-popfr)
  319.          (fx= (lambda-max-temps (car args)) 0))
  320.         (else
  321.          (receive (r1 r2) (apply read-registers op args)
  322.            (or (fx= write r1) (fx= write r2)))))))))
  323.     
  324.  
  325.