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 / riscgen.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  6.8 KB  |  179 lines
  1. (herald (back_end riscgen)
  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 node)
  28.   (destructure (((then else #f #f arg) (call-args node)))
  29.     (let ((acc (->addressable node (leaf-value arg))))
  30.       (emit-compare jump-op/jn= nil-reg acc then else))))
  31.  
  32.  
  33. (define (generate-header-type-test node tag)
  34.   (destructure (((then else #f #f arg) (call-args node)))
  35.     (let ((acc (->register node (leaf-value arg))))
  36.       (emit risc/and (machine-num #x7f) acc scratch)
  37.       (emit-compare jump-op/jn= scratch (machine-num tag) else then))))
  38.  
  39. (define (generate-tag-type-test node tag)
  40.   (destructure (((then else #f #f arg) (call-args node)))
  41.     (let ((acc (->register node (leaf-value arg))))
  42.       (emit risc/and (machine-num 3) acc scratch)
  43.       (emit-compare jump-op/jn= scratch (machine-num tag) else then))))
  44.  
  45. (define (generate-nonvalue-test node)
  46.   (destructure (((then else #f #f arg) (call-args node)))
  47.     (let ((acc (->register node (leaf-value arg))))
  48.       (emit risc/and (machine-num #xff) acc scratch)
  49.       (emit-compare jump-op/jn= scratch (machine-num header/nonvalue) else then))))
  50.  
  51.  
  52. (define (generate-one-arg node compute)
  53.   (destructure (((cont arg) (call-args node)))
  54.       (let* ((var (leaf-value arg))
  55.              (acc (->register node var))
  56.          (t-reg (get-target-register node cont acc nil)))
  57.     (compute acc t-reg)
  58.     (mark-continuation node t-reg))))
  59.     
  60. (define (generate-closure-enclosing-object node)
  61.   (generate-one-arg
  62.    node
  63.    (lambda (acc t-reg)
  64.      (emit risc/load 'l (reg-offset acc -2) extra) ;template
  65.      (emit risc/load 'uw (reg-offset extra template/pointer) scratch)
  66.      (emit risc/sub scratch acc t-reg))))
  67.  
  68. (define (generate-template-enclosing-object node)
  69.   (generate-one-arg
  70.    node
  71.    (lambda (acc t-reg)
  72.      (emit risc/load 'l (reg-offset acc template/offset) scratch)
  73.      (emit risc/sub scratch acc t-reg))))
  74.  
  75. ;;; %make-extend template = AN, bytes = scratch, extend returned in an
  76. (define (generate-make-vector-extend node)
  77.   (destructure (((#f type length size) (call-args node)))
  78.     (let ((acc (->register node (leaf-value length))))
  79.       (free-register node AN)
  80.       (emit risc/sll (machine-num 6) acc AN)
  81.       (emit risc/or (machine-num (leaf-value type)) AN AN)
  82.       (lock AN))
  83.     (let ((acc (lookup-value node (leaf-value size))))
  84.       (generate-move acc scratch)
  85.       (generate-slink-call slink/make-extend))  
  86.     (unlock AN)
  87.     (mark-continuation node AN)))
  88.  
  89. (define (generate-make-extend node)
  90.   (destructure (((#f template size) (call-args node)))
  91.     (let ((acc (lookup-value node (leaf-value template))))
  92.       (free-register node AN)
  93.       (generate-move acc AN)
  94.       (lock AN))
  95.     (let ((acc (lookup-value node (leaf-value size))))
  96.       (generate-move acc scratch)
  97.       (generate-slink-call slink/make-extend))  
  98.     (unlock AN)
  99.     (mark-continuation node AN)))
  100.  
  101. (define (generate-make-cell node)
  102.   (let* ((cont ((call-arg 1) node))
  103.      (reg (get-target-register node cont nil nil)))
  104.     (cond ((and (lambda-node? cont)
  105.         (eq? (variable-definition (car (lambda-variables cont))) 'one))
  106.        (mark-continuation node reg))
  107.           (else
  108.            (free-register node AN)
  109.            (generate-move (machine-num 4) scratch)               ; 1 slot
  110.            (generate-move (machine-num header/cell) AN)
  111.            (generate-slink-call slink/make-extend)  
  112.            (mark-continuation node AN)))))
  113.  
  114. ;;; %make-pair returns pair in AN
  115. (define (generate-make-pair node)
  116.   (free-register node AN)
  117.   (generate-slink-call slink/make-pair)
  118.   (mark-continuation node AN))           
  119.  
  120.  
  121. (define (generate-slink-ref node)
  122.   (generate-primitive-reg-ref node 'slink))
  123.  
  124. (define (generate-task-ref node)
  125.   (generate-primitive-reg-ref node 'task))
  126.  
  127. (define (generate-set-slink-ref node)
  128.   (generate-set-primitive-reg-ref node 'slink))
  129.  
  130. (define (generate-set-task-ref node)
  131.   (generate-set-primitive-reg-ref node 'task))
  132.  
  133.  
  134. (define (generate-primitive-reg-ref node reg)
  135.   (destructure (((cont arg) (call-args node)))
  136.    (if (fixnum? (leaf-value arg))
  137.     (let ((t-reg (get-target-register node cont nil nil)))
  138.       (xcase reg
  139.     ((slink) (emit risc/load 'l (reg-offset nil-reg (leaf-value arg)) t-reg)))
  140.       (mark-continuation node t-reg)))))
  141.                                                                   
  142.  
  143. (define (generate-set-primitive-reg-ref node reg)
  144.   (destructure (((#f arg val) (call-args node))) 
  145.    (if (fixnum? (leaf-value arg))
  146.        (let ((acc (->register node (leaf-value val))))
  147.          (xcase reg
  148.        ((slink) (emit risc/store 'l acc (reg-offset nil-reg (leaf-value arg)))))))))
  149.  
  150.   
  151. (define (generate-stack-pointer node)
  152.   (let ((cont ((call-arg 1) node)))
  153.     (let ((dest (get-target-register node cont nil nil)))
  154.       (generate-move SP dest)
  155.       (mark-continuation node dest))))
  156.  
  157. (define (generate-frame-header node)
  158.   (generate-one-arg
  159.    node
  160.    (lambda (acc t-reg)
  161.      (emit risc/load 'l (reg-offset acc -2) extra)
  162.      (emit risc/sub (machine-num 2) extra t-reg))))
  163.  
  164. (define (generate-frame-sp node)
  165.   (generate-one-arg
  166.    node
  167.    (lambda (acc t-reg)
  168.      (emit risc/add (machine-num 2) acc t-reg))))
  169.  
  170. ;;; %nary-setup required = scratch
  171. (define (generate-nary-setup node required)             
  172.   (if (eq? (lambda-strategy node) strategy/stack)
  173.       (emit risc/sub NARGS zero NARGS))                           ; !!!
  174.   (generate-move (machine-num required) vector)
  175.   (generate-slink-call slink/nary-setup)  
  176.   (mark (lambda-rest-var node) AN))
  177.  
  178.                                       
  179.