home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / vaxbookkeep.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  4.7 KB  |  139 lines
  1. (herald vaxbookkeep)
  2.   
  3. (define-constant *pointer-registers* 6)
  4. (define-constant *scratch-registers* 4)
  5. (define-constant *argument-registers* 4)
  6. (define-constant *real-registers* 10)
  7. (define-constant *pointer-temps* 64)
  8. (define-constant *scratch-temps* 5)
  9. (define-constant *no-of-registers* 
  10.                  (+ *pointer-temps* *scratch-temps* *real-registers*))
  11.  
  12. (define-constant *maximum-number-of-arguments* *pointer-temps*)             
  13.         
  14. (define-constant S0 0)
  15. (define-constant S1 1)
  16. (define-constant S2 2)
  17. (define-constant S3 3)
  18. (define-constant NARGS 3)
  19. (define-constant P 4)
  20. (define-constant A1 5)
  21. (define-constant A2 6)
  22. (define-constant A3 7)
  23. (define-constant A4 8)
  24. (define-constant AN 9)
  25. (define-constant AN-1 8)
  26. (define-constant TP -1)
  27. (define-constant nil-reg -2)
  28. (define-constant SP -3)
  29. (define-constant TASK -4)
  30.  
  31.  
  32. (define *pos-list1* (make-vector 5))
  33. (define *pos-list2* (make-vector 6))
  34.   
  35.  
  36. (let ((base  '((5 . rep/pointer)
  37.                (6 . rep/pointer)
  38.                (7 . rep/pointer)
  39.                (8 . rep/pointer))))
  40.   (set (vref *pos-list1* 0) (sublist base 0 0))
  41.   (set (vref *pos-list1* 1) (sublist base 0 1))
  42.   (set (vref *pos-list1* 2) (sublist base 0 2))
  43.   (set (vref *pos-list1* 3) (sublist base 0 3))
  44.   (set (vref *pos-list1* 4) (sublist base 0 4)))
  45.  
  46.  
  47. (let ((base  '((4 . rep/pointer)
  48.                (5 . rep/pointer)
  49.                (6 . rep/pointer)
  50.                (7 . rep/pointer)
  51.                (8 . rep/pointer))))
  52.   (set (vref *pos-list2* 0) (sublist base 0 0))
  53.   (set (vref *pos-list2* 1) (sublist base 0 1))
  54.   (set (vref *pos-list2* 2) (sublist base 0 2))
  55.   (set (vref *pos-list2* 3) (sublist base 0 3))
  56.   (set (vref *pos-list2* 4) (sublist base 0 4))
  57.   (set (vref *pos-list2* 5) (sublist base 0 5)))
  58.  
  59.  
  60.  
  61.  
  62.  
  63.  
  64. (define (reg-positions i proc?)       
  65.   (cond ((fx<= i (if proc? 5 4))
  66.          (vref (if proc? *pos-list2* *pos-list1*) i))
  67.         (else
  68.          (append (if proc? (vref *pos-list2* 5) (vref *pos-list1* 4))
  69.                  (make-num-list (fx- i (if proc? 5 4)))))))
  70.  
  71. (define (make-num-list amount)
  72.   (let ((end (fx+ (fx+ *real-registers* P) amount)))
  73.     (do ((i (fx+ *real-registers* P) (fx+ i 1))
  74.          (l '() (cons (cons i 'rep/pointer) l)))
  75.         ((fx>= i end) (reverse! l)))))
  76.  
  77. (define (do-trivial-lambda call-node node reg-rep)
  78.   (let ((offset (environment-cic-offset (lambda-env node))))
  79.     (cond ((eq? (lambda-strategy node) strategy/hack)
  80.            (generate-move-address (reg-offset SP (fx+ offset 2)) 
  81.                                   (car reg-rep)))
  82.           ((fx= offset 0)
  83.            (generate-move AN (car reg-rep)))
  84.           (else
  85.            (generate-move-address (reg-offset AN offset) (car reg-rep))))
  86.     (cond ((reg-node (car reg-rep))
  87.                 => kill))
  88.     (lock (car reg-rep))))
  89.  
  90.                                                                             
  91. ;;; MAKE-HEAP-CLOSURE The first member of the closure corresponds to the
  92. ;;; template so we call %make-extend with this template and the size of the
  93. ;;; closure to be created.  Then we fill in the slots with the need variables
  94. ;;; and the addresses of templates for any closure-internal-closures.
  95.  
  96. (define (make-heap-closure node closure)
  97.   (let* ((members (closure-members closure))
  98.          (template-binder (variable-binder (car members))))
  99.     (walk (lambda (var)
  100.             (lambda-queue (variable-binder var)))
  101.           members)
  102.     (free-register node AN)
  103.     (let ((cl (environment-closure (lambda-env template-binder))))
  104.       (cond ((closure-cit-offset cl)
  105.              (let ((acc (lookup node cl nil)))
  106.                (free-register node AN)
  107.                (generate-move acc AN)))
  108.             (else
  109.              (generate-move-address (template template-binder) AN))))
  110.     (lock AN)
  111.     (generate-extend node (closure-size closure))
  112.     (walk (lambda (pair)
  113.       (let ((var (car pair))
  114.             (offset (cdr pair)))
  115.         (cond ((eq? var *dummy-var*))
  116.               ((memq? var members)
  117.                (generate-move-address (template (variable-binder var))
  118.                                       (reg-offset AN
  119.                                                   (fx- offset tag/extend))))
  120.               (else
  121.                (really-rep-convert node
  122.                                    (access-value node var)
  123.                                    (variable-rep var)
  124.                                    (reg-offset AN
  125.                                                (fx- offset tag/extend))
  126.                                    (variable-rep var))))))
  127.       (cdr (closure-env closure)))
  128.     (unlock AN)))
  129.  
  130.  
  131. (define (generate-extend node n)
  132.   (free-register node S1)
  133.   (free-register node S2)
  134.   (generate-move (machine-num (fx- n CELL)) S1)   ;; don't include template
  135.   (generate-slink-jump slink/make-extend))
  136.  
  137. (define (exchange-hack movers)
  138.   (ignore movers) '#f)
  139.