home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / comp / assembler / mark.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  6.4 KB  |  152 lines
  1. (herald (assembler mark t 0)
  2.         (env t (assembler as_open) (assembler fg) (assembler ib)))
  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. ;;; Compute initial address (minimum spans); make table of SDF's and
  28. ;;; of marks.  Set mark addresses, mark sdf pos, ib sdf pos, ib-addresses
  29.  
  30. ;;;; MARKER
  31.  
  32. (define-structure-type sdf
  33.   span crossers selector first-width width next-dirty vars indices backwards?)
  34.                                                
  35. ;;; multiplex 2 fields of the structure
  36.  
  37. (define-integrable sdf-mark sdf-span)
  38. (define-integrable sdf-label sdf-width)
  39.  
  40. (define (cons-sdf l ws fw i)
  41.   (let ((sdf (make-sdf)))
  42.     (set (sdf-span          sdf) *empty*) ; initial span will be the mark
  43.     (set (sdf-crossers      sdf) '())
  44.     (set (sdf-selector      sdf) ws)
  45.     (set (sdf-first-width   sdf) fw)
  46.     (set (sdf-width         sdf) l)       ; initial width is actually the label
  47.     (set (sdf-next-dirty    sdf) nil)
  48.     (set (sdf-indices       sdf) i)       ; index for width var and displ var 
  49.                                           ; in VARS
  50.     sdf
  51.     ))
  52.  
  53. ;;; Statistics hack.
  54.                                         
  55. (define (count-align-sdfs sdfs)
  56.   (let ((sdfs-length (vector-length sdfs)))
  57.     (do ((i 0 (fx+ i 1))
  58.          (count 0 (if (empty? (sdf-span (vref sdfs i))) (fx+ count 1) count)) )
  59.         ((fx>= i sdfs-length)
  60.          count))))
  61.  
  62. (lset *mark-addresses* nil)
  63. (lset *mark-sdf-positions* nil)
  64. (lset *sdfs* nil)
  65.  
  66. ;;; Number of sdf's precedeing some spot.  This number is remembered for
  67. ;;; each mark or label, as encountered.  This is used in later processing
  68. ;;; to fixup labels and marks after the width of each sdf has been determined.
  69.  
  70. (lset *current-sdf-number* -1)
  71.  
  72. ;;; Returns last address = size in bits (minimum possible)
  73.  
  74. (define (marker ibv mark-count span-count)
  75.     ;; these should be a bind, debug for now.
  76.     (set *mark-addresses* (make-vector mark-count))
  77.     (set *mark-sdf-positions* (make-vector mark-count))
  78.     (set *sdfs* (make-vector span-count))
  79.     (bind ((*current-sdf-number* 0))
  80.       (let ((ibv-length (vector-length ibv)))
  81.         (do ((i 0 (fx+ i 1))
  82.              (addr 0 (marker-ib addr (vref ibv i))))
  83.             ((fx>= i ibv-length)
  84.              (return addr *sdfs* *mark-addresses* *mark-sdf-positions*))))))
  85.                                                      
  86. (define (marker-ib start-addr ib)
  87.   (let* ((a (ib-align ib))
  88.          (maximum-alignment-filler (if a (car a) 0))
  89.          (start-addr (fx+ start-addr maximum-alignment-filler)))
  90.  
  91.     ;; if alignment is specified, make an alignment sdf
  92.     (set (ib-address ib) start-addr)
  93.     (if a
  94.       (let ((sdf-pos (ib-sdf-number ib)))
  95.         (set *current-sdf-number* (fx+ sdf-pos 1))
  96.         (set (vref *sdfs* sdf-pos) (cons-sdf nil nil nil nil))))
  97.  
  98.     (set (ib-sdf-number ib) *current-sdf-number*)
  99.     (iterate loop ((i's (ib-instructions ib))
  100.                    (addr start-addr))
  101.       (cond ((null? i's) addr)
  102.             (else
  103.              (let ((new-addr (marker-fg addr (car i's) )))
  104.                ;; really just for debugging
  105.                ;; (set (fg-size (car i's)) (fx- new-addr addr))
  106.                (loop (cdr i's) new-addr)))))))
  107.  
  108. (define (marker-fg start-addr fg)
  109.   (let* ((fgt (fg-type fg))
  110.          (vars (fg-vars fg))
  111.          (vals (fg-type-vals fgt)))
  112.     (iterate loop ((ops (fg-type-ops fgt))
  113.                    (addr start-addr))
  114.       (cond ((null? ops) addr)
  115.             (else
  116.              (xselect (car ops)
  117.                ((wop/fix)
  118.                 (destructure (((#f sign width vop voc1 . ops) ops))
  119.                   (loop ops (fx+ addr width))))
  120.                ((wop/@fix)
  121.                 (destructure (((#f sign width-i vop voc1 . ops) ops))
  122.                   (loop ops (fx+ addr (vref vars width-i)))))
  123.                ((wop/proc)
  124.                 (destructure (((#f sign cw-i proc-i vop voc1 . ops) ops))
  125.                   (loop ops (fx+ addr (vref vars cw-i)))))
  126.                ((wop/var)
  127.                 (destructure (((#f sign cw-i opt-i vop voc1 . ops) ops))
  128.                   (loop ops (fx+ addr (vref vars cw-i)))))
  129.  
  130.                ((wop/depending-on)
  131.                 (destructure (((#f sdf#-i sdf-i mark-i fge-i . ops) ops))
  132.                   (let ((sdf (vref vars sdf-i))
  133.                         (sdf# (vref vars sdf#-i)))
  134.                     (set (sdf-mark sdf) (vref vars mark-i))  
  135.                     (set (sdf-vars sdf) vars)
  136.                     (set *current-sdf-number* (fx+ sdf# 1))
  137.                     (set (vref *sdfs* sdf#) sdf)
  138.                     (loop ops (fx+ addr (sdf-first-width sdf))) )))
  139.  
  140.                ((wop/subfield-ic)
  141.                 (destructure (((#f sf-i vop voc1 . ops) ops))
  142.                   (loop ops (marker-fg addr (vref vars sf-i)))))
  143.                
  144.                ((wop/mark)
  145.                 (destructure (((#f marker-i . ops) ops))
  146.                   (set (vref *mark-sdf-positions* (vref vars marker-i))
  147.                        *current-sdf-number*)
  148.                   (set (vref *mark-addresses* (vref vars marker-i))
  149.                        addr)
  150.                   (loop ops addr)))
  151.                ))))))
  152.