home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / vaxrep.t < prev   
Encoding:
Text File  |  1988-02-05  |  13.9 KB  |  409 lines
  1. (herald (back_end vaxrep)
  2.   (env t (orbit_top defs)))
  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 (rep-analyze-top node)
  28.   (rep-analyze ((call-arg 1) (lambda-body node)))
  29.   (rep-analyze ((call-arg 1) (lambda-body node))))
  30.  
  31. (define (rep-analyze node)
  32.   (cond ((lambda-node? node)
  33.          (rep-analyze-call (lambda-body node))
  34.          (select (lambda-strategy node)
  35.            ((strategy/label strategy/open) 
  36.             (walk (lambda (var)
  37.                     (or (eq? (variable-type var) type/top)
  38.                         (neq? (variable-rep var) 'rep/pointer)
  39.                         (set (variable-rep var) (most-important-rep var))))
  40.                   (if (continuation? node)
  41.                       (lambda-variables node)
  42.                       (cdr (lambda-variables node)))))))))
  43.  
  44.  
  45. (define (rep-analyze-call node)
  46.   (let ((proc (call-proc node)))
  47.     (cond ((lambda-node? proc)
  48.            (walk rep-analyze (call-args node))
  49.            (rep-analyze-call (lambda-body proc)))
  50.       ((not (primop-node? proc))
  51.            (walk rep-analyze (call-args node)))
  52.           ((eq? (primop-value proc) primop/Y)
  53.            (rep-analyze ((call-arg 1) node))
  54.            (destructure (((body . procs) 
  55.                           (call-args (lambda-body ((call-arg 2) node)))))
  56.              (walk rep-analyze procs)
  57.              (rep-analyze body)))
  58.           (else
  59.        (walk rep-analyze (call-args node))
  60.        (cond ((and (eq? (primop-value proc) primop/contents-location)
  61.                (lambda-node? ((call-arg 1) node))
  62.                (eq? (variable-rep (lambda-cont-var ((call-arg 1) node)))
  63.                 'rep/pointer))
  64.           (set (variable-rep (lambda-cont-var ((call-arg 1) node)))
  65.                (primop.rep-wants (leaf-value ((call-arg 2) node))))))))))
  66.  
  67.  
  68.  
  69. (define (most-important-rep var)
  70.   (iterate loop ((refs (variable-refs var)) (reps '()))
  71.     (cond ((null? refs) 
  72.            (select-rep (reverse! reps) (variable-type var)))
  73.           (else
  74.            (let* ((parent (node-parent (car refs)))
  75.                   (proc (call-proc parent))
  76.                   (number (call-arg-number (node-role (car refs)))))
  77.              (cond ((primop-node? proc)
  78.                     (cond ((primop.rep-wants (primop-value proc))
  79.                            => (lambda (creps)
  80.                 (let ((rep 
  81.                        (nth creps (fx- (fx- number
  82.                                                     (call-exits parent))
  83.                                  1))))
  84.                   (if (neq? rep '*)
  85.                       (loop (cdr refs) (cons rep reps))
  86.                       (let ((cont ((call-arg 1) parent)))
  87.                     (loop (cdr refs)
  88.                           (if (leaf-node? cont)
  89.                           (cons 'rep/pointer reps)
  90.                           (let ((rep (variable-rep
  91.                              (lambda-cont-var cont))))
  92.                         (cons (if (eq? (rep-size rep) 4)
  93.                               rep
  94.                               'rep/integer)
  95.                           reps)))))))))
  96.                           ((eq? (primop-value proc) primop/contents-location)
  97.                (loop (cdr refs)
  98.                  (cons
  99.                   (if (fx= number 4) 'rep/integer 'rep/pointer)
  100.                   reps)))
  101.                           ((eq? (primop-value proc) primop/set-location)
  102.                (loop (cdr refs)
  103.                  (cons 
  104.                            (cond ((fx= number 5)
  105.                                   'rep/integer)
  106.                                  ((fx= number 3)
  107.                                   (primop.rep-wants 
  108.                                       (leaf-value ((call-arg 2) parent))))
  109.                                  (else 'rep/pointer))
  110.                reps)))
  111.                           (else 
  112.                            (loop (cdr refs) reps))))
  113.                    ((variable-known (leaf-value proc)) 
  114.                     => (lambda (label)
  115.                          (cond ((lambda-rest-var label) 
  116.                                 (loop (cdr refs) reps))
  117.                                (else
  118.                 (loop (cdr refs)
  119.                       (cons (variable-rep (nth (lambda-variables label)
  120.                                    (fx- number 1)))
  121.                         reps))))))
  122.                    (else
  123.                     (loop (cdr refs) (cons 'rep/pointer reps)))))))))
  124.  
  125. (define (select-rep reps type)
  126.   (cond ((null? reps)
  127.      'rep/pointer)
  128.     ((eq? type type/char)
  129.      (car reps))
  130.     (else
  131.      (let ((size (rep-size (car reps))))
  132.        (iterate loop ((r (cdr reps)))
  133.          (cond ((null? r) (car reps))
  134.            ((fx= (rep-size (car r)) size)
  135.             (loop (cdr r)))
  136.            (else
  137.             (car (sort-list! reps (lambda (x y)
  138.                         (fx> (rep-size x) (rep-size y))))))))))))
  139.  
  140.  
  141.  
  142. (define (access-with-rep node value rep)
  143.   (cond ((variable? value)
  144.          (let ((acc (access-value node value)))
  145.            (cond ((rep-converter (variable-rep value) rep)
  146.                   => (lambda (converter)
  147.                        (let* ((rep-type (if (eq? rep 'rep/pointer) 'pointer 'scratch))
  148.                               (reg (if (and (register? acc) 
  149.                                             (eq? (reg-type acc) rep-type)
  150.                                             (dying? value node))
  151.                                         acc
  152.                                         (get-register rep-type node '*))))
  153.                          (converter node acc reg)
  154.                          reg)))
  155.                  (else acc))))
  156.         ((eq? rep 'rep/pointer)
  157.          (access-value node value))
  158.         (else
  159.          (value-with-rep value rep))))
  160.  
  161.  
  162.  
  163. (lset *reps* '(rep/char
  164.                rep/extend
  165.                rep/double
  166.                rep/integer
  167.                rep/integer-8-s
  168.                rep/integer-8-u
  169.                rep/integer-16-s
  170.                rep/integer-16-u
  171.                rep/string
  172.                rep/pointer))
  173.                                       
  174. (define-constant size/byte 1)
  175. (define-constant size/word 2)
  176. (define-constant size/long 4)
  177. (define-constant size/double 8)
  178.  
  179.  
  180. (lset *rep-converter-table* (make-table 'reps))
  181.                    
  182. (walk (lambda (rep)
  183.         (set (table-entry *rep-converter-table* rep) 
  184.              (make-table rep)))
  185.       *reps*)
  186.  
  187. (define (rep-size rep)
  188.   (xcase rep
  189.     ((rep/char rep/integer-8-u rep/integer-8-s) size/byte)
  190.     ((rep/integer-16-u rep/integer-16-s) size/word)
  191.     ((rep/pointer rep/integer rep/extend rep/string) size/long)
  192.     ((rep/double) size/double)))
  193.  
  194.  
  195.  
  196. (define-local-syntax (define-rep-converter from to proc)
  197.   `(set (table-entry (table-entry *rep-converter-table* ',to) ',from)
  198.         ,proc))
  199.  
  200.  
  201. (define-rep-converter rep/pointer rep/extend
  202.   (lambda (node from to)
  203.     (emit vax/addl3 from (machine-num tag/extend) to)))
  204.                    
  205. (define-rep-converter rep/pointer rep/string
  206.   (lambda (node from to)             
  207.     (let ((reg (cond ((register? from) from)
  208.                      (else
  209.                       (generate-move from S0)
  210.                       S0))))
  211.       (emit vax/addl3 (reg-offset reg 2) (reg-offset reg 6) S0)
  212.       (emit vax/addl3 S0 (machine-num tag/extend) to))))
  213.  
  214. (define-rep-converter rep/pointer rep/char
  215.    (lambda (node from to)
  216.      (cond ((register? to)
  217.             (emit vax/ashl (machine-num -8) from to))
  218.            (else
  219.             (let ((reg (get-register 'scratch node '*)))
  220.               (emit vax/ashl (machine-num -8) from reg)
  221.               (emit vax/movb reg to))))))
  222.  
  223.  
  224. (define-rep-converter rep/pointer rep/integer
  225.   (lambda (node from to)
  226.     (emit vax/ashl (machine-num -2) from to)))
  227.  
  228. (define (pointer->integer-16 node from to)
  229.      (cond ((register? to)
  230.             (emit vax/ashl (machine-num -2) from to))
  231.            (else
  232.             (let ((reg (get-register 'scratch node '*)))
  233.               (emit vax/ashl (machine-num -2) from reg)
  234.               (emit vax/movw reg to)))))
  235.  
  236.  
  237. (define-rep-converter rep/pointer rep/integer-16-u
  238.   pointer->integer-16)
  239.  
  240. (define-rep-converter rep/pointer rep/integer-16-s
  241.   pointer->integer-16)
  242.  
  243. (define (pointer->integer-8 node from to)
  244.      (cond ((register? to)
  245.             (emit vax/ashl (machine-num -2) from to))
  246.            (else
  247.             (let ((reg (get-register 'scratch node '*)))
  248.               (emit vax/ashl (machine-num -2) from reg)
  249.               (emit vax/movb reg to)))))
  250.  
  251.  
  252.  
  253. (define-rep-converter rep/pointer rep/integer-8-u
  254.   pointer->integer-8)
  255.  
  256. (define-rep-converter rep/pointer rep/integer-8-s
  257.   pointer->integer-8)
  258.                  
  259.  
  260. ;----------------------------
  261.  
  262. (define-rep-converter rep/char rep/pointer
  263.   (lambda (node from to)
  264.     (let ((temp (if (and (register? to) (eq? (reg-type to) 'scratch))
  265.                     to
  266.                     (get-register 'scratch node '*))))
  267.       (emit vax/movzbl from temp)
  268.       (emit vax/ashl (machine-num 8) temp to)
  269.       (emit vax/movb (machine-num header/char) to))))
  270.                               
  271.  
  272. ;-----------------------------
  273.                                                    
  274. (define-rep-converter rep/integer rep/pointer
  275.   (lambda (node from to)
  276.     (emit vax/ashl (machine-num 2) from to)))
  277.  
  278. ;--------------------------------
  279.  
  280. (define-rep-converter rep/integer-16-s rep/pointer
  281.   (lambda (node from to)
  282.     (rep-convert-safely node from to vax/cvtwl)))
  283.  
  284. (define-rep-converter rep/integer-16-s rep/integer
  285.   (lambda (node from to)
  286.     (emit vax/cvtwl from to)))
  287.  
  288. ;----------------------------------
  289.  
  290. (define-rep-converter rep/integer-16-u rep/pointer
  291.   (lambda (node from to)
  292.     (rep-convert-safely node from to vax/movzwl)))
  293.  
  294. (define-rep-converter rep/integer-16-u rep/integer
  295.   (lambda (node from to)
  296.     (emit vax/movzwl from to)))
  297.  
  298. ;------------------------------------
  299.  
  300. (define-rep-converter rep/integer-8-s rep/pointer
  301.   (lambda (node from to)
  302.     (rep-convert-safely node from to vax/cvtbl)))
  303.  
  304. (define-rep-converter rep/integer-8-s rep/integer
  305.   (lambda (node from to)
  306.     (emit vax/cvtbl from to)))
  307.  
  308. (define-rep-converter rep/integer-8-s rep/integer-16-s
  309.   (lambda (node from to)
  310.     (emit vax/cvtbw from to)))
  311.  
  312. (define-rep-converter rep/integer-8-s rep/integer-16-u
  313.   (lambda (node from to)
  314.     (emit vax/cvtbw from to)))
  315.                                      
  316. ;---------------------------------------
  317.  
  318.  
  319. (define-rep-converter rep/integer-8-u rep/pointer
  320.   (lambda (node from to)
  321.     (rep-convert-safely node from to vax/movzbl)))
  322.  
  323. (define-rep-converter rep/integer-8-u rep/integer
  324.   (lambda (node from to)
  325.     (emit vax/movzbl from to)))
  326.  
  327. (define-rep-converter rep/integer-8-u rep/integer-16-s
  328.   (lambda (node from to)
  329.     (emit vax/movzbw from to)))
  330.  
  331. (define-rep-converter rep/integer-8-u rep/integer-16-u
  332.   (lambda (node from to)
  333.     (emit vax/movzbw from to)))
  334.                   
  335. ;(define-rep-converter rep/double rep/pointer
  336. ;  (lambda (node from to)
  337. ;    (free-register node AN)
  338. ;    (generate-slink-jump slink/make-double-float nil)
  339. ;    (emit vax/movd from (d@r AN 2))
  340. ;    (generate-move AN to)))
  341.  
  342. ;(define-rep-converter rep/pointer rep/double
  343. ;  (lambda (node from to)
  344. ;    (cond ((register? from)
  345. ;           (emit vax/movd (d@r from 2) to))
  346. ;          (else
  347. ;           (let ((reg (get-register 'pointer node '*)))
  348. ;             (emit vax/movl from reg)
  349. ;             (emit vax/movd (d@r reg 2) to))))))
  350.  
  351.  
  352.  
  353. ;------------------------------------------
  354.  
  355. (define (rep-converter from-rep to-rep)
  356.   (table-entry (table-entry *rep-converter-table* to-rep) from-rep))
  357.  
  358.  
  359. (define (rep-convert-safely node from to inst)
  360.   (let ((temp (if (eq? (reg-type to) 'scratch)
  361.                   to
  362.                   (get-register 'scratch node '*))))
  363.     (emit inst from temp)
  364.     (emit vax/ashl (machine-num 2) temp to)))
  365.  
  366. (define (really-rep-convert node from from-rep to to-rep)
  367.   (cond ((rep-converter from-rep to-rep)
  368.          => (lambda (converter) (converter node from to)))
  369.         ((eq? to-rep 'rep/pointer)
  370.          (generate-move from to))
  371.         ((neq? from to)
  372.          (emit (vax-2op 'mov (rep-size to-rep)) from to))))
  373.       
  374.  
  375.  
  376. (define (rep-push node value to-rep)
  377.   (cond ((addressable? value)
  378.          (emit vax/pushl (value-with-rep value to-rep)))
  379.         (else
  380.          (let ((access (access-value node value))
  381.                (from-rep (variable-rep value)))
  382.            (cond ((eq? from-rep to-rep)
  383.                   (emit vax/pushl access))
  384.                  ((neq? (rep-size to-rep) size/long)
  385.                   (emit vax/pushl (machine-num 0))
  386.                   (really-rep-convert node access from-rep (@r 14) to-rep))
  387.                  (else
  388.                   (really-rep-convert node access from-rep (@-r 14) to-rep))))))
  389.   (increment-stack))
  390.  
  391. (define (value-with-rep value rep)
  392.   (xcond ((char? value)
  393.           (xcond ((eq? rep 'rep/char)
  394.                   (machine-num (char->ascii value)))
  395.                  ((eq? rep 'rep/pointer)
  396.                   (machine-num (fixnum-logior (fixnum-ashl (char->ascii value) 8)
  397.                                               header/char)))))
  398.          ((fixnum? value)
  399.           (cond ((eq? rep 'rep/pointer)
  400.                  (lit value))
  401.                 (else
  402.                  (machine-num value))))
  403.          ((eq? value '#T)
  404.           (machine-num header/true))
  405.          ((or (eq? value '#F) (eq? value '()))
  406.           nil-reg)))
  407.                 
  408.  
  409.