home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / mipssuspend.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  11.6 KB  |  339 lines
  1. (herald maxsuspend (env tsys (link suspend)))
  2.  
  3. (define (suspend obj out-spec x?)
  4.   (set (experimental?) x?)
  5.   (really-suspend obj out-spec 'o))
  6.  
  7. ;;; Look at a Unix a.out description and template.doc
  8.  
  9. (define initial-symbol-count 6)
  10.  
  11.  
  12. (define-constant SIZE-OF-HEADERS 164)
  13. (define-constant RELOC-SIZE 10)
  14. (define-constant MAGIC #o524)
  15. (define-constant RELOC #x2001)                          
  16. (define-constant TEXT-SYM 0)
  17. (define-constant DATA-SYM 2)
  18.  
  19. (define (vgc-foreign foreign)
  20.   (let* ((heap (lstate-impure *lstate*))
  21.          (addr (+area-frontier heap))
  22.          (name (foreign-name foreign))
  23.          (desc (object nil
  24.                  ((heap-stored self) (lstate-impure *lstate*))
  25.                  ((heap-offset self) addr)
  26.                  ((write-descriptor self stream)
  27.                   (write-data stream (fx+ addr tag/extend)))
  28.                  ((write-store self stream)
  29.                   (write-int stream header/foreign)
  30.                   (write-slot name stream)
  31.                   (write-int stream 0)))))
  32.     (set (+area-frontier heap) (fx+ addr 12))
  33.     (push (+area-objects heap) desc)                
  34.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  35.     (generate-slot-relocation name (fx+ addr 4))
  36.     (cymbal-thunk (symbol->string name) 0)
  37.     (foreign-reloc-thunk (lstate-symbol-count *lstate*) (fx+ addr 8))
  38.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  39.     desc))
  40.  
  41. (define (generate-slot-relocation obj slot-address)
  42.   (cond ((or (fixnum? obj) (immediate? obj)))
  43.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  44.          (reloc-thunk DATA-SYM slot-address))
  45.         (else
  46.          (reloc-thunk TEXT-SYM slot-address))))
  47.  
  48. (define (text-relocation addr)
  49.   (reloc-thunk TEXT-SYM addr))
  50.  
  51. (define (data-relocation addr)
  52.   (reloc-thunk DATA-SYM addr))
  53.  
  54. (define (reloc-thunk type address) nil)
  55.  
  56. (define (foreign-reloc-thunk type address) 
  57.   (push (lstate-data-reloc *lstate*)
  58.         (cons address type)))
  59.             
  60. (lset the-string-table nil)
  61.  
  62. (define (cymbal-thunk stryng value)
  63.  (push (lstate-symbols *lstate*)
  64.   (object (lambda (stream)                    
  65.             (xcond ((fx<= (string-length stryng) 8)
  66.                     (write-string stream stryng)
  67.                     (do ((i (string-length stryng) (fx+ i 1)))
  68.                         ((fx= i 8))  
  69.                       (vm-write-byte stream 0)))
  70.                    ((table-entry the-string-table stryng)
  71.                     => (lambda (offset)
  72.                          (write-int stream 0)
  73.                          (write-int stream offset))))
  74.             (cond ((fixnum? value)            ; undefined external (foreign)
  75.                    (write-int stream 0)
  76.                    (write-half stream 0)    ; section number
  77.                    (write-half stream 0)    ; type
  78.                    (vm-write-byte stream 2))
  79.                   (else
  80.                    (write-int stream
  81.                   (fx+ (if (eq? value (lstate-null *lstate*))
  82.                        3
  83.                        (extend-elt value 0))
  84.                    (lstate-pure-size *lstate*)))
  85.                    (write-half stream 2)    ; section
  86.                    (write-half stream 0)    ; type
  87.                    (vm-write-byte stream 2)))
  88.             (vm-write-byte stream 0)
  89.             (vm-write-byte stream 0)
  90.             (vm-write-byte stream 0))
  91.           ((cymbal-thunk.stryng self) stryng))))
  92.  
  93. (define-operation (cymbal-thunk.stryng thunk))
  94.  
  95. (define (write-slot obj stream)
  96.   (cond ((fixnum? obj)
  97.          (write-fixnum stream obj))
  98.         ((immediate? obj)
  99.          (write-immediate stream obj))
  100.         ((null? obj)
  101.          (write-descriptor (lstate-null *lstate*) stream))
  102.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  103.          => (lambda (desc) (write-descriptor desc stream)))
  104.         (else
  105.          (error "bad immediate type ~s" obj))))
  106.  
  107. (define-integrable (write-data stream int)
  108.   (write-int stream (fx+ #x400000 int)))
  109.  
  110. (define-integrable (write-text stream int)
  111.   (write-int stream (fx+ #x60 int)))
  112.  
  113. (define (write-immediate stream imm)
  114.   (let ((int (descriptor->fixnum imm)))
  115.     (write-half stream (fx+ (fixnum-ashl int 2) 1))
  116.     (write-half stream (fixnum-ashr int 14))))
  117.  
  118.  
  119. (define (write-scratch stream obj i)
  120.   (let ((offset (fixnum-ashl i 2)))
  121.     (write-half stream (mref-16-u obj offset))
  122.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  123.  
  124. (define (write-int stream int)
  125.   (write-half stream int)
  126.   (let ((int (fixnum-ashr int 16)))
  127.     (write-half stream int)))
  128.  
  129. (define (write-half stream int)
  130.   (vm-write-byte stream int)
  131.   (let ((int (fixnum-ashr int 8)))
  132.     (vm-write-byte stream int)))
  133.  
  134. (define (write-fixnum stream fixnum)
  135.   (write-half stream (fixnum-ashl fixnum 2))
  136.   (write-half stream (fixnum-ashr fixnum 14)))
  137.  
  138. (define (make-global-cymbal proc name)
  139.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  140.        => (lambda (desc)                                
  141.             (cymbal-thunk (string-downcase! (symbol->string name))
  142.                           desc)
  143.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  144.         (else
  145.          (error "~s not defined" name))))
  146.  
  147.  
  148. (define (write-link-file stream)
  149.   (make-global-cymbal big_bang 'big_bang)
  150.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  151.   (cymbal-thunk "the_slink" (lstate-null *lstate*))
  152.   (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  153.   (write-header     stream)
  154.   (write-text-section-header stream)
  155.   (write-data-section-header stream)
  156.   (write-bss-section-header stream)
  157.   (write-area       stream (lstate-pure *lstate*))
  158.   (write-area       stream (lstate-impure *lstate*))
  159.   (write-relocation stream) 
  160.   (write-cymbal&stryng-table stream (reverse (lstate-symbols *lstate*))))
  161.  
  162. (define (write-header stream)
  163.     (write-half stream MAGIC)                 ;magic number
  164.     (write-half stream 3)                     ; # of sections
  165.     (write-int stream 0)                      ; time and date 
  166.     (write-int stream (cymbal-table-offset))
  167.     (write-int stream (lstate-symbol-count *lstate*))
  168.     (write-half stream 0)                      ; no extra header
  169.     (write-half stream #o404))                  ; flags
  170.  
  171. (define (write-text-section-header stream)   
  172.   (write-string stream ".text")
  173.   (vm-write-byte stream 0)
  174.   (vm-write-byte stream 0)
  175.   (vm-write-byte stream 0)
  176.   (write-int stream 0)      ; phys addr
  177.   (write-int stream 0)      ; virtual addr
  178.   (write-int stream (lstate-pure-size *lstate*))
  179.   (write-int stream SIZE-OF-HEADERS)
  180.   (write-int stream 0)      ; no reloc
  181.   (write-int stream 0)      ; no line numbers
  182.   (write-half stream 0)      
  183.   (write-half stream 0)      
  184.   (write-int stream #x20)
  185.   (write-int stream 0)      
  186.   (write-int stream 0))      
  187.   
  188. (define (write-data-section-header stream)   
  189.   (write-string stream ".data")
  190.   (vm-write-byte stream 0)
  191.   (vm-write-byte stream 0)
  192.   (vm-write-byte stream 0)
  193.   (write-int stream (lstate-pure-size *lstate*))      ; phys addr
  194.   (write-int stream (lstate-pure-size *lstate*))      ; virtual addr
  195.   (write-int stream (+area-frontier (lstate-impure *lstate*)))
  196.   (write-int stream (+ SIZE-OF-HEADERS (lstate-pure-size *lstate*)))
  197.   (write-int stream (+ SIZE-OF-HEADERS 
  198.                        (lstate-pure-size *lstate*)
  199.                        (+area-frontier (lstate-impure *lstate*))))
  200.   (write-int stream 0)      ; no line numbers
  201.   (write-half stream (length (lstate-data-reloc *lstate*)))
  202.   (write-half stream 0)      
  203.   (write-int stream #x40)
  204.   (write-int stream 0)      
  205.   (write-int stream 0))      
  206.  
  207. (define (write-bss-section-header stream)   
  208.   (write-string stream ".bss")
  209.   (vm-write-byte stream 0)
  210.   (vm-write-byte stream 0)
  211.   (vm-write-byte stream 0)
  212.   (vm-write-byte stream 0)
  213.   (write-int stream (fx+ (+area-frontier (lstate-impure *lstate*))
  214.                          (lstate-pure-size *lstate*)))      ; phys addr
  215.   (write-int stream (fx+ (+area-frontier (lstate-impure *lstate*))
  216.                          (lstate-pure-size *lstate*)))      ; virt addr
  217.   (write-int stream 0)
  218.   (write-int stream 0)
  219.   (write-int stream 0)
  220.   (write-int stream 0)      
  221.   (write-half stream 0)
  222.   (write-half stream 0)      
  223.   (write-int stream #x80)
  224.   (write-int stream 0)      
  225.   (write-int stream 0))      
  226.  
  227. (define (cymbal-table-offset)
  228.   (+ SIZE-OF-HEADERS 
  229.      (lstate-pure-size *lstate*)
  230.      (+area-frontier (lstate-impure *lstate*))
  231.      (* RELOC-SIZE (length (lstate-data-reloc *lstate*)))))
  232.  
  233. (define (write-area stream area)
  234.   (walk (lambda (x) (write-store x stream))
  235.         (reverse! (+area-objects area))))
  236.  
  237.  
  238. (define (write-relocation stream)
  239.   (walk (lambda (item)      
  240.           (write-int stream (fx+ (car item) (lstate-pure-size *lstate*)))
  241.           (write-int stream (cdr item))
  242.           (write-half stream #x2001))
  243.         (sort-list! (lstate-data-reloc *lstate*)
  244.                     (lambda (x y)      
  245.                        (fx< (car x) (car y))))))
  246.  
  247.  
  248. (define (write-map-entry stream name value) nil)
  249.  
  250. (define  (write-text-and-data-cymbals stream)
  251.     (write-string stream ".text")
  252.     (vm-write-byte stream 0)
  253.     (vm-write-byte stream 0)
  254.     (vm-write-byte stream 0)
  255.     (write-int  stream 0)
  256.     (write-half stream 1)    ; section
  257.     (write-half stream 0)    ; type
  258.     (vm-write-byte stream 3)
  259.     (vm-write-byte stream 1)
  260.     (vm-write-byte stream 0)
  261.     (vm-write-byte stream 0)
  262.  
  263.     (write-int stream (lstate-pure-size *lstate*))
  264.     (write-int stream 0)
  265.     (write-int stream 0)
  266.     (write-int stream 0)
  267.     (write-int stream 0)
  268.  
  269.     (write-string stream ".data")
  270.     (vm-write-byte stream 0)
  271.     (vm-write-byte stream 0)
  272.     (vm-write-byte stream 0)
  273.     (write-int  stream (lstate-pure-size *lstate*))
  274.     (write-half stream 2)    ; section
  275.     (write-half stream 0)    ; type
  276.     (vm-write-byte stream 3)
  277.     (vm-write-byte stream 1)
  278.     (vm-write-byte stream 0)
  279.     (vm-write-byte stream 0)
  280.  
  281.     (write-int stream (+area-frontier (lstate-impure *lstate*)))
  282.     (write-int stream (length (lstate-data-reloc *lstate*)))
  283.     (write-int stream 0)
  284.     (write-int stream 0)
  285.     (write-int stream 0)
  286.  
  287.     (write-string stream ".bss")
  288.     (vm-write-byte stream 0)
  289.     (vm-write-byte stream 0)
  290.     (vm-write-byte stream 0)
  291.     (vm-write-byte stream 0)
  292.     (write-int  stream (fx+ (lstate-pure-size *lstate*) 
  293.                             (+area-frontier (lstate-impure *lstate*))))
  294.     (write-half stream 3)    ; section
  295.     (write-half stream 0)    ; type
  296.     (vm-write-byte stream 3)
  297.     (vm-write-byte stream 1)
  298.     (vm-write-byte stream 0)
  299.     (vm-write-byte stream 0)
  300.  
  301.     (write-int stream 0)
  302.     (write-int stream 0)
  303.     (write-int stream 0)
  304.     (write-int stream 0)
  305.     (write-int stream 0))
  306.  
  307. (define (write-cymbal&stryng-table stream cyms)
  308.   (let ((size (make-stryng-table cyms)))   
  309.     (write-text-and-data-cymbals stream)
  310.     (walk (lambda (cym) (cym stream)) cyms)
  311.     (write-stryng-table stream size cyms)))        
  312.  
  313. (define (make-stryng-table cyms)
  314.   (set the-string-table (make-string-table 'stryngs))
  315.   (iterate loop ((i 4) (cyms cyms))
  316.       (cond ((null? cyms) i)
  317.             (else
  318.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  319.                     (len (string-length string)))
  320.                (cond ((fx<= len 8)
  321.                       (loop i (cdr cyms)))
  322.                      (else                      
  323.                       (set (table-entry the-string-table string) i)
  324.                       (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))))
  325.                                                        
  326.  
  327. (define (write-stryng-table stream size cyms)
  328.   (write-int stream size)
  329.   (do ((cyms cyms (cdr cyms)))
  330.       ((null? cyms))
  331.     (let* ((string (cymbal-thunk.stryng (car cyms)))
  332.            (len (string-length string)))
  333.       (cond ((fx<= len 8))
  334.             (else                      
  335.              (write-string stream string)
  336.              (vm-write-byte stream 0))))))
  337.  
  338.  
  339.