home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / m68arithgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  14.5 KB  |  311 lines
  1. (herald (back_end m68arithgen)
  2.   (env t (orbit_top defs) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define (m68-op op)
  28.   (xcase op                
  29.     ((mov) m68/move)
  30.     ((add) m68/add)
  31.     ((sub) m68/sub)
  32.     ((and) m68/and)
  33.     ((cmp) m68/cmp)
  34.     ((or)  m68/or)
  35.     ((xor) m68/eor)))
  36.                                              
  37. (define (m68-size rep)
  38.   (xcase rep
  39.     ((rep/char rep/integer-8-u rep/integer-8-s) .b)
  40.     ((rep/integer-16-u rep/integer-16-s) .w)
  41.     ((rep/pointer rep/integer) .l)))
  42.  
  43.  
  44. (define (fixnum-comparator node inst)       
  45.   (comparator node inst fixnum?))
  46.  
  47. (define (character-comparator node inst)
  48.   (comparator node inst char?))
  49.  
  50. (define (comparator node inst type)
  51.   (destructure (((then else () ref1 ref2) (call-args node)))
  52.     (let* ((val1 (leaf-value ref2))     ;; ARGHH opposite of VAX for cond branch
  53.            (val2 (leaf-value ref1))
  54.            (rep (cond ((and (variable? val1) 
  55.                             (neq? (variable-rep val1) 'rep/pointer))
  56.                        (variable-rep val1))
  57.                       ((variable? val2) (variable-rep val2))
  58.                       (t 'rep/pointer))))
  59.       (let ((access2 (access-with-rep node val2 rep)))
  60.         (protect-access access2)
  61.         (let ((access1 (access-with-rep node val1 rep)))
  62.           (cond ((register? access1)
  63.                  (emit m68/cmp (m68-size rep) access2 access1)
  64.                  (emit-jump (get-jop inst rep t) else then))
  65.                 ((register? access2)
  66.                  (emit m68/cmp (m68-size rep) access1 access2)
  67.                  (emit-jump (get-jop inst rep nil) else then))
  68.                 ((and (type val2) (not (type val1)))
  69.                  (emit m68/cmp (m68-size rep) access2 access1)
  70.                  (emit-jump (get-jop inst rep t) else then))
  71.                 ((and (type val1) (not (type val2)))
  72.                  (emit m68/cmp (m68-size rep) access1 access2)
  73.                  (emit-jump (get-jop inst rep nil) else then))
  74.                 (t
  75.                  (emit m68/move (m68-size rep) access2 SCRATCH)
  76.                  (emit m68/cmp (m68-size rep) access1 SCRATCH)
  77.                  (emit-jump (get-jop inst rep nil) else then))))
  78.         (release-access access2)))))
  79.                                                 
  80. (define (get-jop inst rep reverse?)
  81.   (xcase inst 
  82.     ((jneq) jump-op/jn=)
  83.     ((jgeq)
  84.      (case rep
  85.        ((rep/char rep/integer-8-u rep/integer-16-u)  ;;; unsigned guys
  86.         (if reverse? jump-op/uj<= jump-op/uj>=))
  87.        (else
  88.          (if reverse? jump-op/j<= jump-op/j>=))))))
  89.             
  90.  
  91. (define (generate-char->ascii node)
  92.   (destructure (((cont arg) (call-args node)))
  93.     (receive (t-spec t-rep) (continuation-wants cont)
  94.       (let ((var (leaf-value arg))
  95.             (t-reg (get-target-register node t-spec))) 
  96.         (lock t-reg)            
  97.         (cond ((variable? var)
  98.                (let ((acc (access-value node var)))
  99.                  (unlock t-reg)
  100.                  (kill-if-dying var node)
  101.                  (case (variable-rep var)
  102.                    ((rep/char)
  103.                     (really-rep-convert node acc 'rep/integer-8-u
  104.                                                 t-reg t-rep))
  105.                    (else
  106.                     (let ((reg (if (eq? (reg-type t-reg) 'scratch)
  107.                                    t-reg
  108.                                    SCRATCH)))
  109.                       (generate-move acc reg)
  110.                       (emit m68/lsr .w (machine-num (if (eq? t-rep 'rep/pointer)
  111.                                                         6 8))
  112.                                        reg)
  113.                       (generate-move reg t-reg))))))
  114.               (else
  115.                (emit m68/move .l 
  116.                      (access-with-rep node (char->ascii var) t-rep) 
  117.                      t-reg)))
  118.           (mark-continuation node t-reg)))))
  119.  
  120. (define (generate-ascii->char node)
  121.   (destructure (((cont arg) (call-args node)))
  122.     (receive (t-spec t-rep) (continuation-wants cont)
  123.       (let ((var (leaf-value arg))
  124.             (t-reg (get-target-register node t-spec)))
  125.         (lock t-reg)                        
  126.         (cond ((variable? var)
  127.                (let ((acc (access-value node var)))
  128.                  (unlock t-reg)
  129.                  (kill-if-dying var node)
  130.                  (case (variable-rep var)
  131.                    ((rep/pointer)
  132.                     (case t-rep 
  133.                       ((rep/pointer)
  134.                        (let ((reg (if (eq? (reg-type t-reg) 'scratch)
  135.                                       t-reg SCRATCH)))
  136.                          (generate-move acc reg)
  137.                          (emit m68/asl .w (machine-num 6) reg)
  138.                          (emit m68/and .l (machine-num #xffff) reg)
  139.                          (emit m68/move .b (machine-num header/char) reg)
  140.                          (generate-move reg t-reg)))
  141.                       (else                         
  142.                        (generate-move acc t-reg)
  143.                        (emit m68/lsr .w (machine-num 2) t-reg))))
  144.                    (else
  145.                     (case t-rep
  146.                       ((rep/pointer)
  147.                        (let ((reg (if (eq? (reg-type t-reg) 'scratch)
  148.                                       t-reg SCRATCH)))
  149.                          (emit m68/move (m68-size (variable-rep var)) acc reg)
  150.                          (emit m68/asl .w (machine-num 8) reg)
  151.                          (emit m68/and .l (machine-num #xffff) reg)
  152.                          (emit m68/move .b (machine-num header/char) reg)
  153.                          (generate-move reg t-reg)))
  154.                       (else
  155.                        (if (neq? acc t-reg)
  156.                            (emit m68/move (m68-size (variable-rep var)) acc t-reg))))))))
  157.               (else
  158.                (emit m68/move .l
  159.                      (access-with-rep node (ascii->char var) t-rep)
  160.                      t-reg)))
  161.           (mark-continuation node t-reg)))))
  162.  
  163. (define (generate-fixnum-binop node inst commutes? strange?)
  164.  (case inst 
  165.    ((ashl ashr) (do-ash node inst))
  166.    ((and or xor) (do-logical node inst))
  167.    (else
  168.   (destructure (((cont right left) (call-args node)))
  169.     (receive (t-spec t-rep) (continuation-wants cont)
  170.       (let* ((lvar (leaf-value left))
  171.              (rvar (leaf-value right))
  172.              (l-acc (access-with-rep-reg node lvar t-rep t-spec)))
  173.         (protect-access l-acc)
  174.         (let ((r-acc (access-with-rep-reg node rvar t-rep t-spec)))
  175.           (release-access l-acc) 
  176.           (let ((l-target? (and (register? l-acc) 
  177.                                 (dying? lvar node) 
  178.                                 commutes?))
  179.                 (r-target? (and (register? r-acc) 
  180.                                 (dying? rvar node))))
  181.             (cond ((and l-target?
  182.                         (or (not r-target?) 
  183.                             (eq? t-spec l-acc)))
  184.                    (emit (m68-op inst) (m68-size t-rep) r-acc l-acc)
  185.                    (kill lvar)
  186.                    (mark-continuation node l-acc))
  187.                   (r-target?
  188.                    (emit (m68-op inst) (m68-size t-rep) l-acc r-acc)
  189.                    (kill rvar)
  190.                    (mark-continuation node r-acc))
  191.                   (else
  192.                    (protect-access l-acc)
  193.                    (let ((t-reg (cond ((not (register? t-spec))
  194.                                        (get-register t-spec node '*))
  195.                                       ((and (not (locked? t-spec))
  196.                                             (maybe-free t-spec cont))
  197.                                         t-spec)
  198.                                       (else
  199.                                        (get-register (reg-type t-spec) node '*)))))
  200.                      (release-access l-acc)
  201.                      (emit m68/move (m68-size t-rep) r-acc t-reg)
  202.                      (emit (m68-op inst) (m68-size t-rep) l-acc t-reg)                                                                       
  203.                      (mark-continuation node t-reg))))))))))))
  204.  
  205. (define (do-logical node inst)
  206.   (destructure (((cont right left) (call-args node)))
  207.     (receive (t-spec t-rep) (continuation-wants cont)
  208.       (let* ((lvar (leaf-value left))
  209.              (rvar (leaf-value right))
  210.              (l-acc (access-with-rep-reg node lvar t-rep t-spec)))
  211.         (protect-access l-acc)
  212.         (let ((r-acc (access-with-rep-reg node rvar t-rep t-spec)))
  213.           (cond ((and (register? l-acc) 
  214.                       (eq? (reg-type l-acc) 'scratch)
  215.                       (dying? lvar node))
  216.                  (cond ((or (and (register? r-acc) 
  217.                                  (eq? (reg-type r-acc) 'pointer))
  218.                             (and (eq? inst 'xor)
  219.                                  (not (register? r-acc))
  220.                                  (not (fixnum? rvar))))
  221.                         (emit m68/move (m68-size t-rep) r-acc SCRATCH)
  222.                         (emit (m68-op inst) (m68-size t-rep) SCRATCH l-acc))
  223.                        (else
  224.                         (emit (m68-op inst) (m68-size t-rep) r-acc l-acc)))
  225.                  (release-access l-acc)
  226.                  (kill lvar)
  227.                  (mark-continuation node l-acc))
  228.                 ((and (register? r-acc) 
  229.                       (eq? (reg-type r-acc) 'scratch)
  230.                       (dying? rvar node))
  231.                  (cond ((or (and (register? l-acc) 
  232.                                  (eq? (reg-type l-acc) 'pointer))
  233.                             (and (eq? inst 'xor)
  234.                                  (not (register? l-acc))
  235.                                  (not (fixnum? lvar))))
  236.                         (emit m68/move (m68-size t-rep) l-acc SCRATCH)
  237.                         (emit (m68-op inst) (m68-size t-rep) SCRATCH r-acc))
  238.                        (else
  239.                         (emit (m68-op inst) (m68-size t-rep) l-acc r-acc)))
  240.                  (release-access l-acc)
  241.                  (kill rvar)
  242.                  (mark-continuation node r-acc))
  243.                 (else
  244.                  (let ((t-reg (if (and (register? t-spec) 
  245.                                        (eq? (reg-type t-spec) 'scratch)
  246.                                        (maybe-free t-spec cont))
  247.                                   t-spec
  248.                                   (get-register 'scratch node '*))))
  249.                    (if (neq? r-acc t-reg)
  250.                        (emit m68/move (m68-size t-rep) r-acc t-reg))
  251.                    (cond ((or (and (register? l-acc) 
  252.                                    (eq? (reg-type l-acc) 'pointer))
  253.                               (eq? inst 'xor))
  254.                           (emit m68/move (m68-size t-rep) l-acc SCRATCH)
  255.                           (emit (m68-op inst) (m68-size t-rep) SCRATCH t-reg))
  256.                          (else
  257.                           (emit (m68-op inst) (m68-size t-rep) l-acc t-reg)))
  258.                    (release-access l-acc)
  259.                    (mark-continuation node t-reg)))))))))
  260.  
  261.  
  262. (define (do-ash node inst)
  263.   (destructure (((cont right left) (call-args node)))
  264.     (receive (t-spec t-rep) (continuation-wants cont)
  265.       (let* ((lvar (leaf-value left))
  266.              (rvar (leaf-value right))
  267.              (l-acc (access-with-rep-reg node 
  268.                                          lvar 
  269.                                          'rep/integer
  270.                                           t-spec)))
  271.        (protect-access l-acc)
  272.        (let ((r-acc (access-with-rep-reg node 
  273.                                          rvar 
  274.                                          (if (eq? t-rep 'rep/pointer)
  275.                                              'rep/pointer 
  276.                                              'rep/integer)
  277.                                              t-spec)))
  278.          (release-access l-acc)
  279.          (let* ((r-reg (cond ((and (dying? rvar node) 
  280.                                    (register? r-acc)
  281.                                    (eq? (reg-type r-acc) 'scratch))
  282.                               (kill rvar)
  283.                               r-acc)
  284.                              ((and (register? t-spec) 
  285.                                    (eq? (reg-type t-spec) 'scratch)
  286.                                    (not (reg-node t-spec)))
  287.                               (emit m68/move .l r-acc t-spec)
  288.                               t-spec)
  289.                              (else
  290.                               (protect-access l-acc)
  291.                               (protect-access r-acc)
  292.                               (let ((r (get-register 'scratch node '*)))
  293.                                 (release-access l-acc)
  294.                                 (release-access r-acc)
  295.                                 (emit m68/move .l r-acc r)
  296.                                 r))))
  297.                 (l-reg (cond ((and (fixnum? lvar) (fx<= lvar 8) (fx>= lvar 1))
  298.                               (machine-num lvar))
  299.                              ((and (register? l-acc)
  300.                                    (eq? (reg-type l-acc) 'scratch))
  301.                               l-acc)
  302.                              (else
  303.                               (emit m68/move .l l-acc SCRATCH)
  304.                               SCRATCH))))
  305.            (emit (xcase inst ((ashl) m68/asl) ((ashr) m68/asr)) .l l-reg r-reg)
  306.            (if (and (eq? t-rep 'rep/pointer) 
  307.                     (eq? inst 'ashr))
  308.                (emit m68/and .b (machine-num #b11111100) r-reg))
  309.            (mark-continuation node r-reg)))))))
  310.  
  311.