home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / risclocgen.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  10.8 KB  |  273 lines
  1. (herald (back_end risclocgen)
  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. ;;; Copyright (c) 1985 David Kranz
  28.                              
  29. (define (generate-set-location node)    ;; cont type-primop value . args
  30.   ((xselect (length (call-args node))
  31.      ((4) generate-set-fixed-accessor)
  32.      ((5) generate-set-vector-elt))
  33.    node))
  34.  
  35. ;;; We assume these offsets are less than the maximum, 16 bits or whatever
  36.  
  37. (define (generate-set-fixed-accessor node)
  38.   (destructure (((#f type value loc) (call-args node)))
  39.     (let* ((prim (leaf-value type))
  40.        (loc (leaf-value loc))
  41.            (do-it 
  42.             (lambda (access)
  43.               (cond ((and (eq? prim primop/cell-value)
  44.                           (eq? (variable-definition loc) 'one))
  45.                      (let ((lc (lookup-value node loc)))
  46.                (if (register? lc)
  47.                (generate-move access lc)
  48.                (emit risc/store 'l access lc))
  49.                        (cond ((and (register? lc) (temp-loc loc))
  50.                               => (lambda (lc)
  51.                                    (set (temp-node lc) nil)
  52.                                    (set (temp-loc loc) nil))))))
  53.                     (else
  54.                      (let ((reg (->register node loc)))
  55.                        (emit risc/store 'l
  56.             access
  57.             (reg-offset reg (primop.location-specs prim)))))))))
  58.              (let ((reg (cond ((lambda-node? value)
  59.                    (access/make-closure node value))
  60.                   (else
  61.                    (->register node (leaf-value value))))))
  62.                (lock reg)
  63.                (do-it reg)
  64.                (unlock reg)))))
  65.  
  66.                     
  67. (define (generate-set-vector-type-length node)
  68.   (destructure (((#f vec val) (call-args node)))
  69.     (let ((breg (->register node (leaf-value vec)))
  70.           (var (leaf-value val)))
  71.       (lock breg)
  72.       (generate-move (lookup-value node var) scratch)
  73.       (emit risc/sll (machine-num 6) scratch scratch)
  74.       (emit risc/or (machine-num header/slice) scratch scratch)
  75.       (emit risc/store 'l scratch (reg-offset breg -2))
  76.       (unlock breg))))
  77.                
  78.                                                      
  79.                     
  80. (define (generate-set-vector-elt node)
  81.   (destructure (((#f type value loc idex) (call-args node)))
  82.     (let* ((primop (leaf-value type))
  83.        (rep (primop.rep-wants primop))
  84.        (location (leaf-value loc))
  85.        (idex (leaf-value idex))
  86.        (reg (->register node location)))
  87.       (lock reg)
  88.       (let* ((access (if (lambda-node? value)
  89.              (access/make-closure node value)
  90.              (->register node (leaf-value value)))))
  91.     (lock access)
  92.     (case rep
  93.       ((rep/pointer)
  94.        (cond ((and (fixnum? idex) (fx<= (fx* idex 4) *max-extend-displ*))
  95.           (emit risc/store 'l access
  96.             (reg-offset reg (fx+ (fx* idex 4) 2))))
  97.          (else
  98.           (emit risc/add reg (->register node idex) VECTOR)
  99.           (emit risc/store 'l access (reg-offset VECTOR 2)))))
  100.       ((rep/string)
  101.        (emit risc/load 'l (reg-offset reg 6) VECTOR)
  102.        (emit risc/sra (machine-num 2) (->register node idex) scratch)
  103.        (emit risc/add scratch VECTOR VECTOR)
  104.        (emit risc/load 'l (reg-offset reg 2) extra)
  105.        (emit risc/sra (machine-num 8) access scratch)
  106.        (emit risc/add extra VECTOR VECTOR)
  107.        (emit risc/store 'b scratch (reg-offset VECTOR 2)))
  108.       (else
  109.        (cond ((and (fixnum? idex) (fx<= idex *max-extend-displ*))
  110.           (if (eq? rep 'rep/char)
  111.               (emit risc/sra (machine-num 8) access scratch)
  112.               (emit risc/sra (machine-num 2) access scratch))
  113.           (emit risc/store (store-size rep) scratch
  114.             (reg-offset reg (fx+ idex 2))))
  115.          (else
  116.           (let ((i-reg (->register node idex)))
  117.             (if (eq? rep 'rep/char)
  118.             (emit risc/sra (machine-num 8) access scratch)
  119.             (emit risc/sra (machine-num 2) access scratch))
  120.             (emit risc/sra (machine-num 2) i-reg VECTOR)
  121.             (emit risc/add reg VECTOR VECTOR)
  122.             (emit risc/store (store-size rep)
  123.               scratch (reg-offset VECTOR 2)))))))
  124.     (unlock reg)
  125.     (unlock access)))))
  126.  
  127. (define (store-size rep)
  128.   (xcase rep
  129.     ((rep/integer) 'l)
  130.     ((rep/integer-16-u rep/integer-16-s) 'w)
  131.     ((rep/integer-8-u rep/integer-8-s rep/char) 'b)))
  132.                         
  133. (define (generate-contents-location node)
  134.   ((xselect (length (call-args node))
  135.      ((3) generate-fixed-accessor)
  136.      ((4) generate-vector-elt))
  137.    node))
  138.  
  139.  
  140. (define (generate-fixed-accessor node)
  141.   (destructure (((cont type loc) (call-args node)))
  142.    (if (or (leaf-node? cont) (used? (car (lambda-variables cont))))   
  143.          (let* ((type (leaf-value type))
  144.                 (base (leaf-value loc)))
  145.            (cond ((and (eq? type primop/cell-value)
  146.                        (eq? (variable-definition base) 'one))
  147.           (let ((access (lookup-value node base)))
  148.             (protect-access access)
  149.             (let ((target (get-target-register node cont nil nil)))
  150.               (release-access access)
  151.               (generate-move access target)
  152.               (mark-continuation node target))))
  153.                  (else
  154.                   (let* ((reg (->register node base))
  155.              (target (get-target-register node cont reg nil)))
  156.                     (emit risc/load 'l (reg-offset reg (primop.location-specs type))
  157.                                    target)
  158.             (mark-continuation node target))))))))
  159.  
  160.  
  161.  
  162.                                                
  163. (define (generate-vector-type-length node)
  164.   (destructure (((cont vec) (call-args node)))
  165.       (let* ((base (leaf-value vec))
  166.              (reg (->register node base))
  167.          (target (get-target-register node cont reg nil)))
  168.         (emit risc/load 'l (reg-offset reg -2) scratch)
  169.     (emit risc/srl (machine-num 8) scratch scratch)
  170.     (emit risc/sll (machine-num 2) scratch target)
  171.         (mark-continuation node target))))
  172.  
  173.                                                
  174.  
  175. (define (generate-vector-elt node)
  176.   (destructure (((cont type loc idex) (call-args node)))
  177.       (let* ((base (leaf-value loc))
  178.          (idex (leaf-value idex))
  179.          (rep (primop.rep-wants (leaf-value type)))
  180.          (reg (->register node base)))
  181.     (lock reg)
  182.     (let ((I-reg (cond ((variable? idex)
  183.                 (->register node idex))
  184.                ((and (eq? rep 'rep/pointer)
  185.                  (fx<= (fx* idex 4) *max-extend-displ*))
  186.                 nil)
  187.                ((fx<= idex *max-extend-displ*) nil)
  188.                (else (->register node idex)))))
  189.       (unlock reg)
  190.       (let ((t-reg (get-target-register node cont reg i-reg)))
  191.         (case rep
  192.           ((rep/pointer)
  193.            (cond ((null? i-reg)
  194.               (emit risc/load 'l (reg-offset reg (fx+ (fx* idex 4) 2))
  195.                 t-reg))
  196.              (else
  197.               (emit risc/add reg i-reg VECTOR)
  198.               (emit risc/load 'l (reg-offset VECTOR 2) t-reg))))
  199.           ((rep/string)
  200.            (emit risc/load 'l (reg-offset reg 6) VECTOR)
  201.            (cond ((null? i-reg)
  202.               (emit risc/add (machine-num idex) vector vector))
  203.              (else
  204.               (emit risc/sra (machine-num 2) i-reg scratch)
  205.               (emit risc/add scratch VECTOR VECTOR)))
  206.            (emit risc/load 'l (reg-offset reg 2) extra)
  207.            (emit risc/add extra VECTOR VECTOR)
  208.            (emit risc/load 'ub (reg-offset VECTOR 2) scratch)
  209.            (emit risc/sll (machine-num 8) scratch t-reg)
  210.            (emit risc/or (machine-num header/char) t-reg t-reg))
  211.           (else
  212.            (let ((inst  (xcase rep
  213.                    ((rep/integer) 'l)
  214.                    ((rep/integer-16-s) 'sw)
  215.                    ((rep/integer-16-u) 'uw)
  216.                    ((rep/integer-8-s) 'sb)
  217.                    ((rep/integer-8-u rep/char) 'ub))))
  218.          (cond ((null? i-reg)
  219.             (emit risc/load inst (reg-offset reg (fx+ idex 2)) scratch))
  220.                (else
  221.             (emit risc/sra (machine-num 2) i-reg VECTOR)
  222.             (emit risc/add reg VECTOR VECTOR)
  223.             (emit risc/load inst (reg-offset VECTOR 2) scratch)))
  224.          (cond ((neq? rep 'rep/char)
  225.             (emit risc/sll (machine-num 2) scratch t-reg))
  226.                (else
  227.             (emit risc/sll (machine-num 8) scratch t-reg)
  228.             (emit risc/or (machine-num header/char)
  229.                   t-reg t-reg))))))
  230.         (mark-continuation node t-reg))))))
  231.  
  232. (define (generate-make-pointer node)
  233.   (destructure (((cont loc idex) (call-args node)))
  234.       (let* ((base (leaf-value loc))
  235.          (index (leaf-value idex))
  236.          (reg (->register node base)))
  237.     (lock reg)
  238.     (let ((I-reg (if (and (fixnum? index)
  239.                   (fx<= (fx* index 4) (fx- *max-extend-displ* 4)))
  240.              (machine-num (fx+ (fx* index 4) 4))
  241.              (->register node index))))
  242.       (unlock reg)
  243.       (let ((t-reg (get-target-register node cont reg i-reg)))
  244.         (emit risc/add i-reg reg t-reg)
  245.         (if (register? i-reg)
  246.         (emit risc/add (machine-num 4) t-reg t-reg))
  247.         (mark-continuation node t-reg))))))
  248.  
  249.  
  250.                     
  251. (define (generate-%chdr node)
  252.   (destructure (((#f vec val) (call-args node)))
  253.     (let ((reg (->register node (leaf-value vec)))
  254.           (val (leaf-value val)))
  255.       (lock reg)                                              
  256.       (cond ((and (fixnum? val) (fx<= (fixnum-ashl val 8) *max-displ*))
  257.          (emit risc/load 'l (reg-offset reg -2) extra)
  258.          (emit risc/sub (machine-num (fixnum-ashl val 8)) extra extra)
  259.          (emit risc/store 'l extra (reg-offset reg -2))
  260.          (emit risc/load 'l (reg-offset reg 6) scratch)
  261.          (emit risc/add (machine-num val) scratch scratch)
  262.              (emit risc/store 'l scratch (reg-offset reg 6)))
  263.             (else
  264.              (let* ((val (->register node val)))
  265.            (emit risc/load 'l (reg-offset reg -2) extra)
  266.            (emit risc/sll (machine-num 6) val scratch)
  267.            (emit risc/sub scratch extra extra)
  268.            (emit risc/store 'l extra (reg-offset reg -2))
  269.            (emit risc/load 'l (reg-offset reg 6) scratch)
  270.            (emit risc/srl (machine-num 2) val VECTOR)
  271.            (emit risc/add VECTOR scratch scratch)
  272.            (emit risc/store 'l scratch (reg-offset reg 6)))))
  273.       (unlock reg))))