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