home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / assembler / spas.t < prev    next >
Encoding:
Text File  |  1990-04-12  |  7.0 KB  |  252 lines
  1. (herald spas)
  2.  
  3. (define maybe-pushfr 'maybe-pushfr)
  4. (define maybe-popfr 'maybe-popfr)
  5.  
  6. (define (emit-jump 1tag)
  7.   (cond ((and (node? 1tag)
  8.           (lambda-node? 1tag)
  9.           (eq? (lambda-strategy 1tag) strategy/heap))
  10.      (push (ib-instructions *current-ib*)
  11.            (list jbr-inst nil jump-op/jabs
  12.              (cons 'template (maybe-cons-an-ib 1tag))))
  13.      (push (ib-instructions *current-ib*)
  14.            (list sparc/noop nil)))
  15.     (else
  16.      (set (ib-cc *current-ib*) jump-op/jabs)
  17.      (let ((1next (maybe-cons-an-ib 1tag)))
  18.        (set (ib-1next *current-ib*) 1next)
  19.        (push (ib-previous 1next) *current-ib*)))))
  20.  
  21. (define (emit-branch-and-link l)
  22.   (push (ib-instructions *current-ib*)
  23.     (list jbr-inst nil jump-op/jl
  24.           (cond ((fixnum? l) l)
  25.             ((and (node? l) (eq? (lambda-strategy l) strategy/heap))
  26.              (cons 'template (maybe-cons-an-ib l)))
  27.             (else
  28.              (cons 'label (maybe-cons-an-ib l)))))))
  29.  
  30. (define (emit-branch l)
  31.   (push (ib-instructions *current-ib*)
  32.     (list jbr-inst nil jump-op/jabs
  33.           (cons 'label (maybe-cons-an-ib l)))))
  34.  
  35. (define (emit-avoid-jump 1tag)
  36.   (set (ib-avoid-jump? *current-ib*) '#t)
  37.   (emit-jump 1tag))
  38.  
  39. (define (emit-compare cc reg1 reg2 1tag 0tag)
  40.   (emit risc/sub reg2 reg1 zero)
  41.     (set (ib-cc *current-ib*) cc)
  42.     (let ((1next (maybe-cons-an-ib 1tag)))
  43.       (set (ib-1next *current-ib*) 1next)
  44.       (push (ib-previous 1next) *current-ib*))
  45.     (and 0tag
  46.      (let ((0next (maybe-cons-an-ib 0tag)))
  47.        (set (ib-0next *current-ib*) 0next)
  48.        (push (ib-previous 0next) *current-ib*))))
  49.  
  50.  
  51. (define (assembly-list is bv)
  52.   (do ((is is (cdr is))
  53.        (i 0 (fx+ i CELL)))
  54.       ((null? is) repl-wont-print)
  55.     (format t "~&~d:~8t" i)
  56.     (write-i-bytes bv i)
  57.     (destructure (((op comment . args) (car is)))
  58.       (format t "~20t~a~40t" (apply instruction-as-string op i args))
  59.       (if comment
  60.       (apply format t (car comment) (cdr comment))))))
  61.  
  62. (define (assemble-bits size is)
  63.   (let ((code (make-bytev size)))
  64.     (set *is* is)
  65.     (set *bits* code)
  66.     (do ((is is (cdr is))
  67.      (i 0 (fx+ i CELL)))
  68.     ((null? is)
  69.      (format *noise+terminal* "~&; assembled ~d bytes~%" size)
  70.      code)
  71.       (destructure (((op comment . args) (car is)))
  72.     (apply op code i args)))))
  73.  
  74.  
  75. (define (add-to-front block)
  76.   (cond ((or (not block) (ib-address block)))
  77.     ((fx> (length (ib-previous block)) 1)
  78.      (push *blocks-pending* block))
  79.     (else
  80.      (modify *blocks-pending* (lambda (x) (append! x (list block)))))))
  81.  
  82.  
  83. (define (linearize-code-blocks i is)
  84.   (if (null? *blocks-pending*)
  85.       (return i is)
  86.       (let ((ib (pop *blocks-pending*)))
  87.     (cond ((ib-address ib) (linearize-code-blocks i is))
  88.           (else
  89.     (set (ib-address ib) i) 
  90.     (iterate loop ((i i) (ib ib) (newis (ib-instructions ib)) (is is))
  91.       (cond ((null? newis)
  92.          (let ((0next (ib-0next ib))
  93.                (1next (ib-1next ib)))
  94.            (cond ((not 0next) 
  95.               (cond ((null? 1next)
  96.                  (linearize-code-blocks i is))
  97.                 ((and (not (ib-avoid-jump? ib))
  98.                       (any? ib-avoid-jump?
  99.                         (ib-previous 1next))
  100.                       (not (ib-address 1next)))
  101.                  (add-to-front (ib-0next 1next))
  102.                  (add-to-front (ib-1next 1next))
  103.                  (add-jump-no-return 1next i is))
  104.                 ((not (ib-address 1next))
  105.                  (set (ib-address 1next) i)
  106.                  (loop i 1next (ib-instructions 1next) is))
  107.                 (else
  108.                  (add-jump-no-return 1next i is))))
  109.              ((not (ib-address 1next))
  110.               (add-to-front 0next)
  111.               (modify (ib-cc ib) reverse-branch)
  112.               (receive (i is) (add-jump 0next i is (ib-cc ib))
  113.                 (set (ib-address 1next) i)
  114.                 (loop i 1next (ib-instructions 1next) is)))
  115.              ((not (ib-address 0next))
  116.               (receive (i is) (add-jump 1next i is (ib-cc ib))
  117.                 (set (ib-address 0next) i)
  118.                             (loop i 0next (ib-instructions 0next) is)))
  119.              ((preferred-arm? 0next 1next)
  120.               (modify (ib-cc ib) reverse-branch)
  121.               (receive (i is) (add-jump 0next i is (ib-cc ib))
  122.                 (add-jump-no-return 1next i is)))
  123.              (else
  124.               (receive (i is) (add-jump 1next i is (ib-cc ib))
  125.                 (add-jump-no-return 0next i is))))))
  126.         (else
  127.          (let ((inst (caar newis)))
  128.            (select inst
  129.            ((maybe-pushfr)
  130.             (receive (is incr)
  131.                      (figure-pushfr is (lambda-max-temps (caddr (car newis))))
  132.               (loop (fx+ i incr) ib (cdr newis) is)))
  133.            ((maybe-popfr)
  134.             (receive (is incr)
  135.                      (figure-popfr is (lambda-max-temps (caddr (car newis))))
  136.               (loop (fx+ i incr) ib (cdr newis) is)))
  137.            (else
  138.             (loop (fx+ i CELL) ib (cdr newis) (cons (car newis) is)))))))))))))
  139.  
  140.  
  141. (define (preferred-arm? ib1 ib2)
  142.   (let ((node1 (ib-node ib1))
  143.     (node2 (ib-node ib2)))
  144.     (and (node? node1)
  145.      (node? node2)
  146.      (fx< (lambda-trace node1) (lambda-trace node2)))))
  147.     
  148.  
  149. (define (reverse-branch cc)
  150.   (select cc
  151.     ((jump-op/jabs jump-op/jl) cc)
  152.     (else (- cc))))
  153.  
  154. #|
  155. (define (figure-pushfr is n)
  156.   (cond ((fx= n 0) (return is 0))
  157.     ((fx< n *real-registers*)
  158.      (return
  159.       `((,sparc/save () (lit . -64) ,SP ,SP)
  160.         ,@is)
  161.       CELL))
  162.     (else
  163.      (let ((bump (* (fx+ (fx- n *real-registers*) 1) 4)))
  164.        (return 
  165.         `((,sparc/save () (lit . ,(- (+ bump 64))) ,SP ,SP)
  166.         ,@is)
  167.         CELL)))))
  168.  
  169. (define (figure-popfr is n)
  170.   (cond ((fx= n 0) (return is 0))
  171.     (else
  172.      (return
  173.       `((,sparc/restore () ,zero ,zero ,zero)
  174.         ,@is)
  175.       CELL))))
  176. |#
  177. (define (add-jump-no-return next i is)
  178.   (receive (i is) (add-jump next i is jump-op/jabs)
  179.     (linearize-code-blocks i is)))
  180.  
  181. #|
  182. (define (add-jump next i is cc)
  183.   (return (fx+ i (fx* CELL 2))
  184.       (cons noop-inst
  185.         (cons (list jbr-inst nil cc (cons 'label next)) is))))
  186.  
  187. (define (need-to-delay? #f #f) '#t)
  188.  
  189. |#
  190.  
  191. (define (add-jump next i is cc)
  192.   (let ((insts (ib-instructions next)))
  193.     (cond ((or (null? insts)
  194.            (fx= cc jump-op/jl)
  195.            (branch-instruction? (car insts)))
  196.        (return (fx+ i (fx* CELL 2))
  197.            (cons noop-inst 
  198.              (cons (list jbr-inst nil cc (cons 'label next))
  199.                    is))))
  200.       ((fx= cc jump-op/jabs)
  201.        (return (fx+ i (fx* CELL 2))
  202.            (cons (car insts) 
  203.              (cons (list jbr-inst nil cc (cons 'label+1 next))
  204.                    is))))
  205.       (else
  206.        (return (fx+ i (fx* CELL 2))
  207.            (cons (car insts) 
  208.              (cons (list jbr-a-inst nil cc (cons 'label+1 next))
  209.                    is)))))))
  210.  
  211. (define (branch-instruction? x)
  212.   (or (eq? (car x) sparc/jmpl)
  213.       (eq? (car x) jbr-inst)
  214.       (eq? (car x) jbr-a-inst)
  215.       (eq? (car x) maybe-popfr)
  216.       (eq? (car x) maybe-pushfr)))
  217.  
  218. (define (figure-pushfr is n)
  219.   (cond ((fx= n 0) (return is 0))
  220.     ((fx= n 1)
  221.      (return
  222.       `((,risc/store () l ,LINK-REG (reg-offset ,SP 0))
  223.         (,risc/add () (lit . -4) ,SP ,SP)
  224.         ,@is)
  225.       (fx* CELL 2)))
  226.     (else
  227.      (let ((bump (* (fx+ (fx- n *real-registers*) 2) 4)))
  228.        (return 
  229.         `((,risc/store () l ,LINK-REG (reg-offset ,SP ,(fx- bump 4)))
  230.           (,risc/add () (lit . ,(- bump)) ,SP ,SP)
  231.         ,@is)
  232.         (fx* CELL 2))))))
  233.  
  234. (define (figure-popfr is n)
  235.   (cond ((fx= n 0) (return is 0))
  236.     ((fx= n 1)
  237.      (return
  238.       `((,risc/add () (lit . 4) ,SP ,SP)
  239.         (,risc/load () l (reg-offset ,SP 0) ,LINK-REG)
  240.         ,@is)
  241.       (fx* CELL 2)))
  242.     (else
  243.      (let ((bump (* (fx+ (fx- n *real-registers*) 2) 4)))
  244.        (return
  245.         `((,risc/add () (lit . ,bump) ,SP ,SP)
  246.           (,risc/load () l (reg-offset ,SP ,(fx- bump 4)) ,LINK-REG)
  247.         ,@is)
  248.       (fx* CELL 2))))))
  249.  
  250.     
  251.  
  252.