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 / spgen.t < prev    next >
Encoding:
Text File  |  1990-06-05  |  11.3 KB  |  310 lines
  1. (herald (back_end spgen)
  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. ;;; GENERATE-HANDLER The situation is that the object is in A1 and its template 
  28. ;;; is in TP.  The  operation is in P.  We must use only the register AN.                                 
  29.  
  30. (define (hacked-get-register node)
  31.   (cond ((reg-node an) 
  32.      (cond ((reg-node an+1) => kill))
  33.      AN+1)
  34.     (else
  35.      AN)))
  36.  
  37. (define (generate-handler node obj)
  38.   (let ((leaves (call-args (lambda-body ((call-arg 3) (lambda-body node)))))
  39.         (methods (cdddr (call-args (lambda-body node)))))
  40.     (cond ((null? methods)
  41.            (emit sparc/jmpl (reg-offset link-reg 0) zero)
  42.            (generate-move nil-reg AN))
  43.           (else
  44.       (bind ((get-register hacked-get-register))
  45.         (mark (lambda-self-var *heap-env*) A1)
  46.         (generate-jump (car leaves))
  47.         (let ((last ((call-arg 3) (lambda-body node))))
  48.           (do ((l leaves (cdr l))
  49.                (methods methods (cdr methods)))
  50.               ((null? l)
  51.                (emit-tag last)
  52.                (emit sparc/jmpl (reg-offset link-reg 0) zero)
  53.            (generate-move nil-reg AN)
  54.                (clear-slots))
  55.             (generate-handler-test obj (car l) 
  56.                                    (car methods) 
  57.                                    (if (null? (cdr l)) last (cadr l))))))))))
  58.  
  59.  
  60. (define (generate-handler-test obj leaf method next)
  61.   (emit-tag leaf)
  62.   (let ((el-hacko (cons nil nil)))
  63.   (emit-compare jump-op/jn= (->register nil (leaf-value leaf)) P next el-hacko)
  64.     (emit-tag el-hacko))
  65.   (lambda-queue method)
  66.   (let ((offset (handler-diff method obj)))
  67.     (emit sparc/sethi offset AN)
  68.     (emit risc/or offset AN AN)
  69.     (emit risc/add  AN vector AN)) ;entry point in vector
  70.   (emit sparc/jmpl (reg-offset link-reg 0) zero)
  71.   (emit-noop))
  72.  
  73.  
  74.   
  75. ;;; %undefined-effect arg = A1
  76. (define (generate-undefined-effect node)
  77.   (let ((acc (lookup-value node (leaf-value ((call-arg 1) node)))))
  78.     (generate-slink-jump slink/undefined-effect)
  79.     (generate-move acc A1)
  80.     (clear-slots)))
  81.       
  82.  
  83. ;;; %set vcell = parassign-extra
  84.  
  85. (define (generate-set node location value)
  86.   (let ((access (if (lambda-node? value)        
  87.             (access/make-closure node value)
  88.             (->register node (leaf-value value)))))
  89.     (protect-access access)
  90.     (let ((loc (lookup node (get-lvalue (leaf-value location)) nil))
  91.       (hack1 (cons nil nil))
  92.       (hack2 (cons nil nil)))
  93.     (release-access access)
  94.     (generate-move loc parassign-extra)
  95.     (generate-move access (reg-offset parassign-extra 2))
  96.     (free-register node AN)
  97.     (lock AN)
  98.     (free-register node AN-1)
  99.     (unlock AN)
  100.     (emit risc/load 'ub (reg-offset parassign-extra 0) scratch)
  101.     (emit-compare jump-op/jn= zero scratch hack1 hack2)
  102.     (emit-tag hack1)                       
  103.     (generate-slink-call slink/set)
  104.     (generate-jump hack2)
  105.     (emit-tag hack2))))
  106.  
  107.  
  108. (define (generate-remove-state-object node)
  109.   (let ((cont (car (call-args node))))
  110.     (if (and (lambda-node? cont)
  111.          (not (lambda-rest-var cont))
  112.          (variable-refs (lambda-cont-var cont)))
  113.     (mark-continuation node AN+1))))
  114.  
  115.  
  116. #|
  117. (define (generate-multiply lvar l-acc r-acc t-reg)
  118.   (if (representable-fixnum? lvar 'add)
  119.       (emit risc/add (machine-num lvar) zero ass-reg) ;%o0
  120.       (emit risc/sra (machine-num 2) l-acc ass-reg)) ;%o0
  121.   (generate-move r-acc extra-args)    ;%o1
  122.   (generate-slink-call slink/fx*)
  123.   (generate-move ass-reg t-reg))
  124.  
  125. (define (generate-divide lvar l-acc r-acc t-reg)
  126.   (cond ((representable-fixnum? lvar 'add) 
  127.      (generate-move-addressable lvar extra-args))
  128.     (else
  129.      (generate-move l-acc extra-args)))
  130.   (generate-move r-acc ass-reg)
  131.   (generate-slink-call slink/fx/)
  132.   (emit risc/sll (machine-num 2) ass-reg t-reg))
  133.  
  134. (define (generate-remainder lvar l-acc r-acc t-reg)
  135.   (cond ((representable-fixnum? lvar 'add)
  136.      (generate-move-addressable lvar extra-args))
  137.     (else
  138.      (generate-move l-acc extra-args)))
  139.   (generate-move r-acc ass-reg)
  140.   (generate-slink-call slink/fx-rem)
  141.   (generate-move ass-reg t-reg))
  142. |#
  143.  
  144. (define (generate-extend node n)
  145.   ;; don't include template
  146.   (generate-move (machine-num (fx- n CELL)) SCRATCH)
  147.   (generate-slink-call slink/make-extend)) ; delay slot
  148.     
  149.  
  150.       
  151. (define (generate-extra-args-cons len)
  152.   (generate-move (machine-num (* len CELL 2)) SCRATCH)
  153.   (generate-slink-call slink/make-extra-args))
  154.  
  155.  
  156. (define (generate-extra-arg-move n)
  157.   (generate-move (reg-offset extra-args
  158.                  (+ (* (- n *first-stack-register*) 8) 1)) n))
  159.  
  160. ;;; This stuff almost duplicates code in parassign
  161. ;;; do-trivial-lambda and indirect-lambda and do-immediate
  162.  
  163. (define (generate-extra-arg-store node arg n)
  164.   (let ((ro (reg-offset extra-args (+ (* n 8) 1))))
  165.     (cond ((lambda-node? arg)
  166.        (cond ((eq? (environment-closure (lambda-env arg)) *unit*)
  167.           (lambda-queue arg)
  168.           (generate-move (lookup node arg nil) ro))
  169.          (else
  170.           (let ((offset (environment-cic-offset (lambda-env arg))))
  171.             (cond ((fx= offset 0)
  172.                (generate-move AN ro))
  173.               (else                   
  174.                (generate-move-address (reg-offset AN offset) ro)))))))
  175.       ((not (addressable? (leaf-value arg)))
  176.        (generate-move (lookup-value node (reference-variable arg)) ro))
  177.       (else
  178.        (generate-move-addressable (leaf-value arg) ro)))))
  179.  
  180. (define (generate-two-fixnums node)
  181.   (destructure (((then else () ref1 ref2) (call-args node)))
  182.     (let ((reg1 (->register node (leaf-value ref1))))
  183.       (lock reg1)
  184.       (let ((reg2 (->register node (leaf-value ref2))))
  185.     (unlock reg1)
  186.         (cond ((target-fixnum? (leaf-value ref2))
  187.            (emit risc/and (machine-num 3) reg1 SCRATCH))
  188.           (else
  189.            (emit risc/or reg1 reg2 SCRATCH)
  190.            (emit risc/and (machine-num 3) SCRATCH SCRATCH)))
  191.         (emit-compare jump-op/jn= SCRATCH zero else then)))))
  192.  
  193. (define (generate-op-with-overflow node op) 
  194.   (destructure (((then else () ref1 ref2) (call-args node)))
  195.     (let ((reg1 (->register node (leaf-value ref1))))
  196.       (lock reg1)
  197.       (let ((reg2 (->register node (leaf-value ref2))))
  198.     (lock reg2)
  199.     (let ((target (get-register node))
  200.           (hack (cons nil nil)))
  201.       (unlock reg1)
  202.       (unlock reg2)
  203.       (xcase op
  204.     ((add)
  205.      (emit risc/add reg2 reg1 target)
  206.      (emit risc/xor reg2 reg1 scratch)
  207.      (emit-compare jump-op/j>= scratch zero hack then)
  208.      (emit-tag hack)
  209.      (emit risc/xor reg2 target scratch)     
  210.      (emit-compare jump-op/j>= scratch zero else then))
  211.     ((subtract) 
  212.      (emit risc/sub reg2 reg1 target)
  213.      (emit risc/xor reg2 reg1 scratch)
  214.      (emit-compare jump-op/j>= scratch zero then hack)
  215.      (emit-tag hack)
  216.      (emit risc/xor reg2 target scratch)     
  217.      (emit-compare jump-op/j>= scratch zero then else)))
  218.       (mark (car (lambda-variables else)) target))))))
  219.  
  220. (define (generate-foreign-call node)
  221.   (destructure (((#f foreign rep-list value-rep . args) (call-args node)))
  222.     (emit risc/store 'l sp (reg-offset nil-reg slink/saved-sp))
  223.     (emit risc/store 'l ssp (reg-offset nil-reg slink/saved-ssp))
  224.     (emit risc/store 'l crit-reg (reg-offset nil-reg slink/saved-crit))
  225.     (let* ((rep-list (map cadr (leaf-value rep-list))))
  226.       (iterate loop ((outs os)    ;%o0
  227.              (in A1)
  228.              (reps (reverse! rep-list)))
  229.     (cond ((null? reps))
  230.           ((null? outs)
  231.            (do ((i (* 23 4) (fx+ i 4)) ;see sparc stack frame
  232.             (reps reps (cdr reps))
  233.             (in in (fx+ in 1)))
  234.            ((null? reps))
  235.          (cond ((eq? (car reps) 'rep/double)
  236.             (bug "Can't handle double in this position"))
  237.                (else
  238.             (cond ((fx< in AN)
  239.                    (pointer->rep in AN (car reps)))
  240.                   (else
  241.                    (emit risc/load 'l 
  242.                      (reg-offset extra-args (+ (* (- in AN) 8) %%car))
  243.                      parassign-extra)
  244.                    (pointer->rep parassign-extra AN (car reps))))
  245.             (emit risc/store 'l AN (reg-offset ssp i))))))
  246.           ((eq? (car reps) 'rep/double) 
  247.            (emit risc/load 'l (reg-offset in 2) (car outs))
  248.            (emit risc/load 'l (reg-offset in 6) (cadr outs))
  249.            (loop (cddr outs) (fx+ in 1) (cdr reps)))
  250.           (else
  251.            (pointer->rep in (car outs) (car reps))
  252.            (loop (cdr outs) (fx+ in 1) (cdr reps))))))
  253.     (generate-move (lookup-value node (leaf-value foreign)) P)
  254.     (emit risc/load 'l (reg-offset P 6) P)
  255.     (generate-move link-reg A5)        ;save continuation
  256.     (emit sparc/jmpl (reg-offset p 0) link-reg)
  257.     (emit sparc/noop)
  258.     (generate-move A5 link-reg)
  259.     (emit risc/load 'l (reg-offset nil-reg slink/saved-sp) sp) ;g1
  260.     (generate-move (machine-num header/true) t-reg) ;g2
  261.   (generate-move zero an+1)        ;g3
  262.   (generate-move zero extra-args)    ;o1
  263.   (generate-move zero extra)        ;o2
  264.   (generate-move zero parassign-extra)    ;o3
  265.   (generate-move zero vector)        ;o4
  266.   (emit risc/store 'l zero (reg-offset nil-reg slink/saved-sp))
  267.   (case (leaf-value value-rep)
  268.     ((rep/undefined ignore))
  269.     ((rep/double)
  270.      (generate-move (machine-num header/double-float) AN)
  271.      (generate-move (machine-num 8) scratch)
  272.      (generate-slink-call slink/make-extend)
  273.      (emit sparc/fstore 0 (reg-offset AN 2))
  274.      (emit sparc/fstore 1 (reg-offset AN 6))
  275.      (generate-move AN A1))
  276.     (else
  277.      (rep->pointer ass-reg A1  (leaf-value value-rep)))) ;ass-reg = %o0
  278.   (generate-move zero ass-reg)))    
  279.        
  280. (define os (list ass-reg extra-args extra parassign-extra vector scratch))
  281.  
  282. (define (pointer->rep from to rep)
  283.   (case rep
  284.     ((rep/pointer) (generate-move from to))
  285.     ((rep/extend) (emit risc/add (machine-num 2) from to))
  286.     ((rep/c-pointer) 
  287.      (emit risc/add (machine-num 2) from to)
  288.      (emit risc/srl (machine-num 2) to to) 
  289.      (emit risc/sll (machine-num 2) to to))
  290.     ((rep/string)
  291.      (emit risc/load 'l (reg-offset from 6) to)
  292.      (emit risc/load 'l (reg-offset from 2) from)
  293.      (emit risc/add from to to)
  294.      (emit risc/add (machine-num 2) to to))
  295.     ((rep/char)
  296.      (emit risc/srl (machine-num 8) from to))
  297.     (else
  298.      (emit risc/sra (machine-num 2) from to))))
  299.  
  300. (define (rep->pointer from to rep)
  301.   (case rep
  302.     ((rep/pointer) (generate-move from to))
  303.     ((rep/extend) (emit risc/sub (machine-num 2) from to))
  304.     ((rep/char)
  305.      (emit risc/sll (machine-num 8) from to)
  306.      (emit risc/or (machine-num header/char) to to))
  307.     (else
  308.      (emit risc/sll (machine-num 2) from to))))
  309.      
  310.