home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / link / suspend.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  13.9 KB  |  384 lines
  1. (herald suspend (env tsys))
  2.  
  3. (define-local-syntax (dotimes spec . body)
  4.   (let ((index (car spec))
  5.         (limit (cadr spec)))
  6.     `(do ((,index 0 (fx+ ,index 1)))
  7.          ((fx= ,index ,limit))
  8.        ,@body)))
  9.  
  10.  
  11. (lset *lstate* nil)
  12.                          
  13. (define (system-suspend path experimental?) 
  14.   (suspend top-level-environments path experimental?))
  15.  
  16. (define-structure-type lstate   ;linker state
  17.     pure            
  18.     impure          
  19.     foreign-reloc   
  20.     foreign                     
  21.     symbols                        
  22.     symbol-count
  23.     text-reloc   ;List of relocation items
  24.     data-reloc
  25.     pure-size
  26.     reloc 
  27.     null
  28.     )
  29.                           
  30. (define lp-table-size (fx* 256 1024))
  31.                                            
  32. (define (create-lstate)
  33.   (let ((l (make-lstate)))
  34.     (set (lstate-foreign l) '())
  35.     (set (lstate-pure l) (make-+area))
  36.     (set (lstate-impure l) (make-+area))
  37.     (set (lstate-symbols l) '())
  38.     (set (lstate-symbol-count l) 0)
  39.     (set (lstate-foreign-reloc l) '())
  40.     (set (lstate-text-reloc l) '())
  41.     (set (lstate-data-reloc l) '())
  42.     (set (lstate-reloc l) (make-lp-table lp-table-size 'reloc-table))
  43.     l))
  44.  
  45.  
  46. (define-structure-type +area         ;A.k.a. "heap"
  47.   frontier      ;Address of next available cell
  48.   objects       ;List of objects allocated
  49.   )
  50.  
  51. (let ((master (stype-master +area-stype)))
  52.   (set (+area-frontier    master) 0)
  53.   (set (+area-objects     master) '()))
  54.                               
  55. (*define t-implementation-env '*boot* 
  56.   (lambda (root-process boot-args debug?)
  57.     (ignore debug?)
  58.     (dispatch-init)
  59.     (set (system-global slink/boot-area-base) (make-vector 0))
  60.     (set (system-global slink/initial-impure-base) top-level-environments)
  61.     (set (*value t-implementation-env '**up**) luser-typed-eof-at-top-level)
  62.     (re-initialize-systems)
  63.     (top-level)))
  64.  
  65. (define (omit null args)
  66.   (walk (lambda (arg)
  67.           (set-lp-table-entry (lstate-reloc *lstate*) arg null))
  68.         args))
  69.        
  70. (block (lset *omit-list* 
  71.          (list *the-initial-symbols*
  72.                *the-initial-modules*
  73.                *code-unit-map*
  74.                *boot-env*
  75.                **cont**
  76.                **up**
  77.                **ret**
  78.  
  79.                bootstrap-env
  80.                boot-adjust-initial-units
  81.                initialize-symbol-table
  82.                make-base-environment
  83.                object-hash-table
  84.                object-unhash-table
  85.                ))
  86.  nil)
  87.  
  88.  
  89. (define (really-suspend object out-spec out-type)                                             
  90.   (format t "~&Suspending ~a ... ~%" out-spec)
  91.   (bind ((*lstate* (create-lstate)))
  92.     (with-open-ports
  93.         ((image (open (filename-with-type (->filename out-spec) out-type) '(out))))
  94.       (omit (set-up-the-slink) (cons *lstate* *omit-list*))
  95.       (modify (system-%link-edit t-system)
  96.           (lambda (x) (fx+ x 1)))
  97.       (vgc object)
  98.       (format t "writing object file~%")
  99.       (set (lstate-pure-size *lstate*) 
  100.            (+area-frontier (lstate-pure *lstate*)))
  101.       (write-link-file image)
  102.       *lstate*)))
  103.                      
  104. (define (set-up-the-slink)
  105.   (modify (+area-frontier (lstate-impure *lstate*))
  106.           (lambda (x) (fx+ x %%slink-size)))
  107.   (let ((null 
  108.          (object nil
  109.            ((heap-stored self) (lstate-impure *lstate*))
  110.            ((heap-offset self) tag/pair)
  111.            ((write-descriptor self stream)
  112.             (write-data stream tag/pair))
  113.            ((write-store self stream)
  114.             (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  115.               (do ((i 0 (fx+ i 4)))
  116.                   ((fx= i pi)
  117.                    (write-int stream 0)
  118.                    (write-int stream (+area-frontier (lstate-pure *lstate*)))
  119.                    (write-data stream 0)
  120.                    (write-data stream (+area-frontier (lstate-impure *lstate*)))
  121.                    (write-int stream (fx-ashl (fx+ (gc-stamp) 1) 2))
  122.                    (do ((i (fx+ i 20) (fx+ i 4)))
  123.                        ((fx= i %%slink-size))
  124.                      (write-int stream 0)))
  125.                 (write-int stream 0)))))))
  126.     (set (lstate-null *lstate*) null)
  127.     (push (+area-objects (lstate-impure *lstate*)) null)
  128.     (text-relocation (fx+ slink/initial-pure-memory-begin 3))
  129.     (text-relocation (fx+ slink/initial-pure-memory-end 3))
  130.     (data-relocation (fx+ slink/initial-impure-memory-begin 3))
  131.     (data-relocation (fx+ slink/initial-impure-memory-end 3))
  132.     null))
  133.  
  134. ;;; Virtual GC
  135.           
  136. (define (vgc obj)
  137.   (cond ((null? obj) (lstate-null *lstate*))
  138.         ((lp-table-entry (lstate-reloc *lstate*) obj))
  139.         ((pair? obj)
  140.          (vgc-pair obj))
  141.         (else
  142.          (let ((header (extend-header obj)))
  143.            (cond ((template-header? header)
  144.                   (vgc-template obj))
  145.                  ((extend? header)
  146.                   (vgc-closure obj header))
  147.                  ((immediate? header)
  148.                   ((vref *suspend-dispatch-vector* 
  149.                          (header-type (extend-header obj)))
  150.                     obj))
  151.                  (else
  152.                   (error "Corrupt-header ~s ~s" obj header)))))))
  153.  
  154.  
  155. (define (vgc-pair pair)
  156.   (let* ((heap (lstate-impure *lstate*))
  157.          (addr (+area-frontier heap))
  158.          (desc (object nil
  159.                  ((heap-stored self) (lstate-impure *lstate*))
  160.                  ((heap-offset self) addr)
  161.                  ((write-descriptor self stream)       
  162.                   (write-data stream (fx+ addr tag/pair)))
  163.                  ((write-store self stream)
  164.                   (write-slot (cdr pair) stream)
  165.                   (write-slot (car pair) stream)))))
  166.       (set (+area-frontier heap) (fx+ addr (fx* CELL 2)))
  167.       (push (+area-objects heap) desc)
  168.       (set-lp-table-entry (lstate-reloc *lstate*) pair desc)
  169.       ;;Trace from the cdr first to linearise lists
  170.       (generate-slot-relocation (cdr pair) addr)
  171.       (generate-slot-relocation (car pair) (fx+ CELL addr))
  172.       desc))
  173.  
  174. (define (vgc-template tmplt)
  175.   (vgc-internal-object tmplt 
  176.                        (template-enclosing-object tmplt) 
  177.                        (template-encloser-offset tmplt)))
  178.  
  179. (define (vgc-closure closure template)
  180.   (cond ((template-internal-bit? template)
  181.          (vgc-internal-object closure 
  182.                               (closure-enclosing-object closure)
  183.                               (closure-encloser-offset closure)))
  184.         (else
  185.          (let* ((ptrs (template-pointer-slots template))
  186.                 (size (fx+ ptrs (template-scratch-slots template))))
  187.            (vgc-extend closure ptrs size)))))
  188.                                              
  189.  
  190. (define (vgc-extend obj ptrs size)
  191.   (let* ((heap (lstate-impure *lstate*))
  192.          (addr (+area-frontier heap))
  193.          (desc 
  194.            (if (fx= ptrs size)
  195.                (object nil
  196.                  ((heap-stored self) (lstate-impure *lstate*))
  197.                  ((heap-offset self) addr)
  198.                  ((write-descriptor self stream)
  199.                   (write-data stream (fx+ addr tag/extend)))
  200.                  ((write-store self stream)
  201.                   (do ((i -1 (fx+ i 1)))
  202.                       ((fx= i ptrs) t)
  203.                     (write-slot (extend-elt obj i) stream))))
  204.                (object nil
  205.                  ((heap-stored self) (lstate-impure *lstate*))
  206.                  ((heap-offset self) addr)
  207.                  ((write-descriptor self stream)
  208.                   (write-data stream (fx+ addr tag/extend)))
  209.                  ((write-store self stream)
  210.                   (do ((i -1 (fx+ i 1)))
  211.                       ((fx= i ptrs)
  212.                        (do ((i i (fx+ i 1)))
  213.                            ((fx= i size) t)
  214.                          (write-scratch stream obj i)))
  215.                     (write-slot (extend-elt obj i) stream)))))))
  216.       (set (+area-frontier heap) (fx+ addr (fx+ (fx* CELL size) CELL)))
  217.       (push (+area-objects heap) desc)
  218.       (set-lp-table-entry (lstate-reloc *lstate*) obj desc)
  219.       (do ((i -1 (fx+ i 1))
  220.            (a addr (fx+ a CELL)))
  221.           ((fx= i ptrs) desc)
  222.         (generate-slot-relocation (extend-elt obj i) a))))
  223.   
  224.  
  225. (define (vgc-internal-object obj obj-encloser offset)
  226.   (let ((encloser (vgc obj-encloser)))
  227.     (cond ((lp-table-entry (lstate-reloc *lstate*) obj))
  228.           (else
  229.            (let* ((addr (fx+ (fixnum-ashl offset 2) 
  230.                              (fx+ (heap-offset encloser) tag/extend)))
  231.                   (desc 
  232.                    (if (bytev? obj-encloser)
  233.                        (object nil
  234.                          ((heap-stored self) (lstate-pure *lstate*))
  235.                          ((write-descriptor self stream)
  236.                           (write-int stream addr)))
  237.                        (object nil
  238.                          ((heap-stored self) (lstate-impure *lstate*))
  239.                          ((write-descriptor self stream)
  240.                           (write-data stream addr))))))
  241.              (set-lp-table-entry (lstate-reloc *lstate*) obj desc)
  242.              desc)))))
  243.  
  244. (define (vgc-bytes bytes vlen pure?)
  245.   (let* ((heap (if pure? (lstate-pure *lstate*) (lstate-impure *lstate*)))
  246.          (addr (+area-frontier heap))
  247.          (end-addr (fx+ CELL (fx+ addr vlen)))
  248.          (desc 
  249.            (if pure?
  250.                (object nil
  251.                  ((heap-stored self) (lstate-pure *lstate*))
  252.                  ((heap-offset self) addr)    
  253.                  ((write-descriptor self stream)
  254.                   (write-int stream (fx+ addr tag/extend)))
  255.                  ((write-store self stream)
  256.                   (write-slot (extend-header bytes) stream)
  257.                   (let ((len (bytev-length bytes)))
  258.                     (do ((i 0 (fx+ i 1)))
  259.                         ((fx>= i len)
  260.                          (dotimes (i (fx- (align len 2) len))
  261.                            (vm-write-byte stream 0)))
  262.                       (vm-write-byte stream (bref bytes i))))))
  263.                (object nil
  264.                  ((heap-stored self) (lstate-impure *lstate*))
  265.                  ((heap-offset self) addr)    
  266.                  ((write-descriptor self stream)
  267.                   (write-data stream (fx+ addr tag/extend)))
  268.                  ((write-store self stream)
  269.                   (write-slot (extend-header bytes) stream)
  270.                   (let ((len (bytev-length bytes)))
  271.                     (do ((i 0 (fx+ i 1)))
  272.                         ((fx>= i len)
  273.                          (dotimes (i (fx- (align len 2) len))
  274.                            (vm-write-byte stream 0)))
  275.                       (vm-write-byte stream (bref bytes i)))))))))
  276.     (set (+area-frontier heap) (align end-addr 2))
  277.     (push (+area-objects heap) desc)
  278.     (set-lp-table-entry (lstate-reloc *lstate*) bytes desc)
  279.     desc))
  280.  
  281.  
  282. (define *suspend-dispatch-vector* (make-vector %%number-of-immediate-types))
  283.  
  284. (let ((gc-copiers
  285.       `(
  286.         (,header/text           ,vgc-text)
  287.         (,header/general-vector ,vgc-general-vector)
  288.         (,header/unit           ,vgc-unit)
  289.         (,header/slice          ,vgc-string)
  290.         (,header/symbol         ,vgc-symbol)
  291.         (,header/bytev          ,vgc-bytev)
  292.         (,header/foreign         ,vgc-foreign)
  293.         (,header/template       ,vgc-template)
  294.         (,header/cell           ,vgc-cell)
  295.         (,header/vcell          ,vgc-vcell)
  296.         (,header/bignum         ,vgc-bignum)
  297.         (,header/double-float   ,vgc-double-float)
  298.         (,header/weak-set       ,vgc-weak)
  299.         (,header/weak-alist     ,vgc-weak)
  300.         (,header/weak-table     ,vgc-weak-table)
  301.         (,header/weak-cell      ,vgc-weak-cell)
  302.         )))
  303.   (vector-fill *suspend-dispatch-vector* vgc-error)
  304.   (walk (lambda (x) (set (vector-elt *suspend-dispatch-vector*
  305.                                      (fixnum-ashr (car x) 2))
  306.                          (cadr x)))
  307.         gc-copiers))
  308.  
  309. (define (vgc-error obj)
  310.   (error "Don't know how to vgc ~s" obj))
  311.  
  312. (define (vgc-text text) 
  313.   (vgc-bytes text (text-length text) (pure? text)))
  314.  
  315. (define (vgc-symbol sym)
  316.   (vgc-bytes sym (symbol-length sym) t))
  317.                                                                                   
  318. (define (vgc-bytev bytev)
  319.   (vgc-bytes bytev (bytev-length bytev) (pure? bytev)))
  320.  
  321. (define (vgc-general-vector vec)
  322.   (vgc-extend vec (vector-length vec) (vector-length vec)))
  323.                                                            
  324. (define (vgc-unit unit)
  325.   (unit-snap-links unit)
  326.   (vgc-extend unit (unit-length unit) (unit-length unit)))
  327.                                                            
  328. (define (vgc-string str)              
  329.   (vgc-extend str 1 2))
  330.  
  331. (define (vgc-cell cell)
  332.   (vgc-extend cell 1 1))
  333.  
  334. (define (vgc-vcell vcell)
  335.   (vgc-extend vcell %%vcell-size %%vcell-size))
  336.  
  337. (define (vgc-bignum bignum)
  338.   (vgc-extend bignum 0 (bignum-length bignum)))
  339.  
  340. (define (vgc-double-float d)
  341.   (vgc-extend d 0 2))
  342.  
  343. (define (vgc-weak weak)
  344.   (vgc-extend weak 1 1))
  345.  
  346. (define (vgc-weak-cell weak)
  347.   (let* ((heap (lstate-impure *lstate*))
  348.          (addr (+area-frontier heap))
  349.          (desc (object nil
  350.                  ((heap-stored self) heap)
  351.                  ((heap-offset self) addr)
  352.                  ((write-descriptor self stream)
  353.                   (write-data stream (fx+ addr tag/extend)))
  354.                  ((write-store self stream)
  355.                   (write-slot (extend-elt weak -1) stream)
  356.                   (write-slot nil stream)))))
  357.     (set (+area-frontier heap) (fx+ addr (fx+ (fx* CELL 1) CELL)))
  358.     (push (+area-objects heap) desc)
  359.     (set-lp-table-entry (lstate-reloc *lstate*) weak desc)
  360.     (generate-slot-relocation nil (fx+ addr CELL))
  361.     desc))
  362.  
  363. (define (vgc-weak-table weak)
  364.   (vgc-extend weak 1 2))
  365.  
  366. (define-integrable (align n m)
  367.   (let ((2^m-1 (fx- (fixnum-ashl 1 m) 1)))
  368.     (fixnum-logand (fx+ n 2^m-1) (fixnum-lognot 2^m-1))))
  369.       
  370. (define-operation (heap-stored obj))
  371. (define-operation (heap-offset obj))           
  372. (define-operation (write-descriptor obj stream))
  373. (define-operation (write-store obj stream))
  374.  
  375.  
  376. (define (unit-snap-links unit)
  377.   (let ((len (unit-length unit)))
  378.     (do ((i 0 (fx+ i 1)))
  379.     ((fx>= i len) t)
  380.       (let ((thing (extend-elt unit i)))
  381.     (or (template? thing)
  382.         (not (extend? thing))
  383.         (neq? (extend-header thing) *link-snapper-template*)
  384.         (set (extend-elt unit i) (extend-elt thing 0)))))))