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 / lookup.t < prev    next >
Encoding:
Text File  |  1989-10-27  |  4.3 KB  |  123 lines
  1. (herald (back_end lookkup)
  2.   (env t (orbit_top defs) (back_end closure) (back_end bookkeep)))
  3.  
  4. (define (all-important-refs-are-calls? var)
  5.   (every? (lambda (ref)
  6.         (or (eq? (node-role ref) call-proc)
  7.         (and (eq? (node-role ref) (call-arg 2))
  8.              (let ((call (node-parent ref)))
  9.                (or (primop-ref? (call-proc call) primop/*define)
  10.                (primop-ref? (call-proc call) primop/*lset))))))
  11.       (variable-refs var)))
  12.  
  13. (define (var-is-vcell? var)
  14.   (and (not (all-important-refs-are-calls? var))
  15.        (neq? var *the-environment*)))
  16.  
  17. ;;; ACCESS-VALUE This is the primary routine to get addressability to values.
  18. ;;; Just a giant case statement.
  19.  
  20.  
  21. (define (lookup-value node value)
  22.   (cond ((and (variable? value)
  23.           (not (variable-binder value))
  24.           (var-is-vcell? value))
  25.      (let ((acc (lookup node (get-lvalue value) nil)))
  26.        (let ((reg (get-register node)))
  27.          (generate-move acc reg)
  28.          (reg-offset reg tag/extend))))
  29.     (else
  30.      (really-access-value node value))))
  31.  
  32. (define (really-access-value node value)               
  33.  (let ((value (cond ((and (variable? value) (variable-known value))
  34.                      => lambda-self-var)
  35.                     (else value))))
  36.   (cond ((register-loc value)
  37.          => (lambda (spec)
  38.               (cond ((fixnum? spec) spec)
  39.             (else (error "Register loc not a fixnum ~s" value)))))
  40.         ((temp-loc value))
  41.         ((variable? value)
  42.          (let ((binder (variable-binder value)))
  43.            (cond ((not binder)
  44.                   (lookup node value nil))
  45.                  ((and (fx= (variable-number value) 0) 
  46.                        (assq binder (closure-env *unit*)))
  47.                   (lookup node binder nil))
  48.                  (else
  49.                   (lookup node value binder)))))
  50.         ((primop? value)
  51.          (if (eq? value primop/undefined)
  52.              zero
  53.              (lookup node value nil)))
  54.         ((eq? value '#T)
  55.          (machine-true-value))
  56.         ((or (eq? value '#F) (eq? value '()))
  57.           nil-reg)
  58.         ((addressable? value)
  59.          (reference-addressable node value))
  60.         (else
  61.          (lookup node value nil)))))
  62.  
  63.  
  64. ;;; LOOKUP If the value is a known procedure, if it is in the unit we get it
  65. ;;; from there, otherwise we get the variable which the known procedure is
  66. ;;; bound to.
  67.  
  68. (define (lookup node value lambda-bound?)
  69.   (xselect (lambda-strategy *heap-env*)
  70.     ((strategy/heap)
  71.      (let ((contour (lambda-self-var *heap-env*)))
  72.        (->register node contour)
  73.        (fetch-from-heap node contour value lambda-bound?)))))
  74.  
  75.  
  76.                                 
  77. (define (get-env var)
  78.   (lambda-env (variable-binder var)))
  79.                                       
  80.  
  81. (define (fetch-from-stack node value lambda-bound?) (error " Fetch from stack"))
  82.  
  83.  
  84. (define (closure-internal-closure? value closure)
  85.   (cond ((neq? closure *unit*)
  86.          (memq? value (closure-members closure)))
  87.         (else
  88.          (or (and (node? value) (lambda-node? value))
  89.              (closure? value)))))
  90.  
  91. (define (fetch-from-heap node contour value lambda-bound?) 
  92.   (iterate loop ((env (get-env contour)) (contour contour)) 
  93.     (let* ((closure (environment-closure env))
  94.        (a-list (closure-env closure))
  95.        (current-offset (environment-cic-offset env)))
  96.       (cond ((assq value a-list)
  97.              => (lambda (pair)
  98.                   (if (closure-internal-closure? value closure)
  99.                       (list (reg-offset (register-loc contour)  ; *** hack
  100.                                         (fx- (cdr pair) current-offset)))
  101.                       (reg-offset (register-loc contour)
  102.                                   (fx- (cdr pair)
  103.                                        (fx+ current-offset tag/extend))))))
  104.             ((and (not lambda-bound?) (closure-cit-offset closure))
  105.          => (lambda (up)
  106.           (into-register node up
  107.              (reg-offset (register-loc contour)
  108.                (fx- (fx- (cdr (assq up a-list)) current-offset) tag/extend)))
  109.           (loop (get-env up) up)))
  110.             ((neq? closure *unit*)
  111.              (into-register node (caadr a-list)
  112.                 (reg-offset  (register-loc contour)
  113.                              (fx+ (fx- 0 current-offset) tag/extend)))
  114.              (loop (get-env (caadr a-list)) (caadr a-list)))
  115.             (else
  116.              (bug "Couldn't find ~s~% in call ~s"
  117.                   value
  118.                   (pp-cps node)))))))
  119.  
  120.  
  121.  
  122.  
  123.