home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / vaxgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  11.2 KB  |  295 lines
  1. (herald (back_end vaxgen)
  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 (generate-nil-test arg)
  28.   (emit vax/cmpl arg nil-reg))
  29.  
  30.     
  31. ;;; Eq?
  32. ;;; ---------------------------------------------------------------------
  33.  
  34.  
  35. (define (eq?-comparator node)
  36.   (destructure (((then else () ref1 ref2) (call-args node)))
  37.     (let ((val1 (leaf-value ref1))
  38.           (val2 (leaf-value ref2)))
  39.       (let ((access (access-with-rep node val2 'rep/pointer)))
  40.         (protect-access access)
  41.         (emit vax/cmpl
  42.               (access-with-rep node val1 'rep/pointer) 
  43.               access)
  44.         (emit-jump 'jneq else then)
  45.         (release-access access)))))
  46.  
  47.  
  48.  
  49.  
  50. (define (one-arg-primitive node)
  51.   (destructure (((cont arg) (call-args node)))
  52.     (receive (t-spec t-rep) (continuation-wants cont)
  53.       (let* ((var (leaf-value arg))
  54.              (dest (cond ((register? t-spec)
  55.                           (cond ((or (not (reg-node t-spec))
  56.                                      (dying? (reg-node t-spec) node))
  57.                                   t-spec)
  58.                                 (else
  59.                                  (get-register (reg-type t-spec) node '*))))
  60.                          ((and (dying? var node) (register-loc var))
  61.                           => (lambda (reg)
  62.                                (if (and (register? reg) (eq? (reg-type reg) t-spec))
  63.                                    reg
  64.                                    (get-register t-spec node '*))))
  65.                          (else
  66.                           (get-register t-spec node '*)))))
  67.         (lock dest)
  68.         (let ((acc (access-value node var)))
  69.           (unlock dest)
  70.           (kill-if-dying var node)
  71.           (return acc dest t-rep))))))
  72.  
  73. (define (generate-closure-enclosing-object node)
  74.      (receive (source target rep) (one-arg-primitive node)
  75.        (let ((creg (cond ((and (register? source) (neq? source target))
  76.                           source)
  77.                          (else
  78.                           (lock target)
  79.                           (block0 (get-register 'pointer node '*)
  80.                                   (unlock target))))))
  81.          (generate-move source creg)
  82.          (let ((sreg (get-register 'scratch node '*)))
  83.            (emit vax/movl (reg-offset creg -2) target)   ; get template
  84.            (emit vax/movzwl (reg-offset target -4) sreg) ; offset field in bytes
  85.            (emit vax/subl3 sreg creg target))    ; pointer and scratch adjoined
  86.          (mark-continuation node target))))
  87.  
  88.  
  89. (define (generate-make-vector-extend node)
  90.   (destructure (((#f type length size) (call-args node)))
  91.     (let ((acc (access-with-rep node (leaf-value length) 'rep/pointer)))
  92.       (free-register node AN)
  93.       (emit vax/ashl (machine-num 6) acc AN)
  94.       (emit vax/movb (machine-num (leaf-value type)) AN)
  95.       (lock AN))
  96.     (let ((acc (access-with-rep node (leaf-value size) 'rep/pointer)))
  97.       (free-register node S1)
  98.       (generate-move acc S1))
  99.     (free-register node S2)
  100.     (generate-slink-jump slink/make-extend)
  101.     (unlock AN)
  102.     (mark-continuation node AN)))
  103.  
  104. (define (generate-make-extend node)
  105.   (destructure (((#f template size) (call-args node)))
  106.     (let ((acc (access-with-rep node (leaf-value template) 'rep/pointer)))
  107.       (free-register node AN)
  108.       (generate-move acc AN)
  109.       (lock AN))
  110.     (let ((acc (access-with-rep node (leaf-value size) 'rep/pointer)))
  111.       (free-register node S1)
  112.       (generate-move acc S1))
  113.     (free-register node S2)
  114.     (generate-slink-jump slink/make-extend)
  115.     (unlock AN)
  116.     (mark-continuation node AN)))
  117.  
  118. (define (generate-make-cell node)
  119.   (let ((cont ((call-arg 1) node)))
  120.     (cond ((and (lambda-node? cont)
  121.                 (eq? (variable-definition (car (lambda-variables cont))) 'one))
  122.            (receive (t-spec t-rep) (continuation-wants cont)
  123.              (mark-continuation node (get-target-register node t-spec))))
  124.           (else
  125.            (free-register node AN)
  126.            (free-register node S1)
  127.            (emit vax/movl (lit 1) S1)               ; 1 slot
  128.            (emit vax/movl (machine-num header/cell) AN)
  129.            (free-register node S2)
  130.            (generate-slink-jump slink/make-extend)
  131.            (mark-continuation node AN)))))
  132.  
  133. (define (generate-make-pair node)
  134.   (free-register node AN)
  135.   (generate-slink-jump slink/make-pair)
  136.   (mark-continuation node AN))           
  137.  
  138.  
  139. (define (generate-slink-ref node)
  140.   (generate-primitive-reg-ref node 'slink))
  141.  
  142. (define (generate-task-ref node)
  143.   (generate-primitive-reg-ref node 'task))
  144.  
  145. (define (generate-set-slink-ref node)
  146.   (generate-set-primitive-reg-ref node 'slink))
  147.  
  148. (define (generate-set-task-ref node)
  149.   (generate-set-primitive-reg-ref node 'task))
  150.  
  151.  
  152. (define (generate-primitive-reg-ref node reg)
  153.   (destructure (((cont arg) (call-args node)))
  154.    (if (fixnum? (leaf-value arg))
  155.     (receive (t-spec t-rep) (continuation-wants cont)
  156.       (let ((dest (get-target-register node t-spec)))
  157.         (xcase reg
  158.       ((slink) (really-rep-convert node (reg-offset nil-reg (leaf-value arg))
  159.                        'rep/pointer dest t-rep))
  160.       ((task) (really-rep-convert node (reg-offset TASK (leaf-value arg))
  161.                       'rep/pointer dest t-rep)))
  162.         (mark-continuation node dest))))))
  163.                                                                   
  164.  
  165. (define (generate-set-primitive-reg-ref node reg)
  166.   (destructure (((#f arg val) (call-args node))) 
  167.    (if (fixnum? (leaf-value arg))
  168.        (let ((acc (access-with-rep node (leaf-value val) 'rep/pointer)))
  169.          (xcase reg
  170.        ((slink) (emit vax/movl acc (reg-offset nil-reg (leaf-value arg))))
  171.        ((task) (emit vax/movl acc (reg-offset TASK (leaf-value arg)))))))))
  172.  
  173.  
  174.   
  175.  
  176. (define (generate-current-continuation node)
  177.   (receive (t-spec t-rep) (continuation-wants ((call-arg 1) node))
  178.     (let ((dest (get-target-register node t-spec)))
  179.       (free-register node dest)
  180.       (emit vax/addl3 (machine-num 2) SP dest)
  181.       (mark-continuation node dest))))
  182.  
  183. (define (generate-stack-pointer node)
  184.   (receive (t-spec t-rep) (continuation-wants ((call-arg 1) node))
  185.     (let ((dest (get-target-register node t-spec)))
  186.       (free-register node dest)
  187.       (emit vax/movl SP dest)
  188.       (mark-continuation node dest))))
  189.  
  190.            
  191. (define (generate-nary-setup node required)             
  192.   (if (eq? (lambda-strategy node) strategy/stack)
  193.       (emit vax/mnegl NARGS NARGS))                           ; !!!
  194.   (do ((i (fx+ A1 required) (fx+ i 1)))
  195.       ((fx>= i (fx- *real-registers* 1)))
  196.     (generate-move i (fx+ *real-registers* (fx- i A1))))
  197.   (generate-move (machine-num required) S0)
  198.   (generate-slink-jump slink/nary-setup)
  199.   (mark (lambda-rest-var node) AN))
  200.  
  201.                                       
  202. ;;; GENERATE-HANDLER The situation is that the object is in A1 and its template 
  203. ;;; is in TP.  The  operation is in P.  We must use only the register AN.                                 
  204.  
  205. (define (hacked-get-register type node where) 
  206.   (ignore type node where)
  207.   (cond ((reg-node an)
  208.      => (lambda (x)
  209.           (set (register-loc x) nil)
  210.           (set (reg-node an) nil))))
  211.   AN)
  212.  
  213. (define (generate-handler node)                            
  214.   (let ((leaves (call-args (lambda-body ((call-arg 3) (lambda-body node)))))
  215.         (methods (cdddr (call-args (lambda-body node)))))
  216.     (cond ((null? methods)
  217.            (emit vax/movl nil-reg AN)
  218.            (emit vax/rsb))
  219.           (else
  220.       (bind ((get-register hacked-get-register))
  221.         (mark (lambda-self-var *lambda*) A1)
  222.         (generate-jump (car leaves))
  223.         (let ((last ((call-arg 3) (lambda-body node))))
  224.           (do ((l leaves (cdr l))
  225.                (methods methods (cdr methods)))
  226.               ((null? l)
  227.                (emit-tag last)
  228.                (emit vax/movl nil-reg AN)
  229.                (emit vax/rsb)
  230.                (clear-slots))
  231.             (generate-handler-test (car l) 
  232.                                    (car methods) 
  233.                                    (if (null? (cdr l)) last (cadr l))))))))))
  234.  
  235. (define (generate-handler-test leaf method next)
  236.   (emit-tag leaf)
  237.   (emit vax/cmpl (access-value nil (leaf-value leaf)) P)
  238.   (let ((el-hacko (cons nil nil)))
  239.     (emit-jump 'jneq next el-hacko)
  240.     (emit-tag el-hacko))
  241.   (lambda-queue method)
  242.   (generate-move-address (template method) AN)
  243.   (emit vax/rsb))
  244.   
  245.  
  246. (define (generate-undefined-effect node)
  247.   (generate-move (access-value node (leaf-value ((call-arg 1) node))) A1)
  248.   (generate-jump-absolute (*d@r 11 slink/undefined-effect))
  249.   (clear-slots))
  250.       
  251. (define (generate-vframe-test amount)
  252.   (let ((hack1 (cons nil nil))
  253.         (hack2 (cons nil nil)))
  254.     (emit vax/cmpb (machine-num header/vframe) (reg-offset sp 0))
  255.     (emit-jump 'jneq hack2 hack1)
  256.     (emit-tag hack1)                       
  257.     (adjust-stack-pointer amount)
  258.     (generate-jump hack2)
  259.     (emit-tag hack2)))
  260.         
  261.  
  262.  
  263. (define (generate-set node location value)
  264.   (let ((access (if (lambda-node? value)        
  265.             (cond ((access/make-closure node value))
  266.               (else AN))
  267.             (access-with-rep node (leaf-value value) 'rep/pointer))))
  268.     (protect-access access)
  269.     (let ((loc (lookup node (get-lvalue (leaf-value location)) nil))
  270.       (hack1 (cons nil nil))
  271.       (hack2 (cons nil nil)))
  272.       (let ((reg (get-register 'pointer node '*)))
  273.     (release-access access)
  274.     (generate-move loc reg)
  275.     (generate-move access (reg-offset reg 2))
  276.     (emit vax/tstb (reg-offset reg 0))
  277.     (emit-jump 'jneq hack1 hack2)
  278.     (emit-tag hack1)                       
  279.     (emit vax/movl reg (reg-offset TASK task/extra-pointer))
  280.     (generate-slink-jump slink/set)
  281.     (generate-jump hack2)
  282.     (emit-tag hack2)))))
  283.  
  284. (define (generate-remove-state-object node)
  285.   (let ((cont (car (call-args node))))
  286.     (if (and (lambda-node? cont)
  287.          (not (lambda-rest-var cont))
  288.          (variable-refs (lambda-cont-var cont)))
  289.     (receive (t-spec t-rep) (continuation-wants cont)
  290.       (let ((dest (get-target-register node t-spec)))
  291.         (emit vax/movl (reg-offset sp 4) dest)
  292.         (mark-continuation node dest)))))
  293.   (or (not (method-lambda (node-parent node)))
  294.       (emit vax/addl2 ($ 20) sp)))
  295.