home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / udata.scm < prev    next >
Text File  |  1999-03-24  |  11KB  |  296 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: udata.scm,v 14.20 1999/03/25 03:44:20 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Simple Microcode Data Structures
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (return-address? object)
  28.   (or (interpreter-return-address? object)
  29.       (compiled-return-address? object)))
  30.  
  31. (define-integrable (interpreter-return-address? object)
  32.   (object-type? (ucode-type return-address) object))
  33.  
  34. (define-integrable (make-return-address code)
  35.   ((ucode-primitive map-code-to-machine-address 2) (ucode-type return-address)
  36.                            code))
  37.  
  38. (define-integrable (return-address/code return-address)
  39.   ((ucode-primitive map-machine-address-to-code 2) (ucode-type return-address)
  40.                            return-address))
  41.  
  42. (define (return-address/name return-address)
  43.   (microcode-return/code->name (return-address/code return-address)))
  44.  
  45. (define (microcode-error name)
  46.   (or (microcode-error/name->code name)
  47.       (error "MICROCODE-ERROR: Unknown name" name)))
  48.  
  49. (define (microcode-return name)
  50.   (or (microcode-return/name->code name)
  51.       (error "MICROCODE-RETURN: Unknown name" name)))
  52.  
  53. (define (microcode-termination name)
  54.   (or (microcode-termination/name->code name)
  55.       (error "MICROCODE-TERMINATION: Unknown name" name)))
  56.  
  57. (define (microcode-type name)
  58.   (or (microcode-type/name->code name)
  59.       (error "MICROCODE-TYPE: Unknown name" name)))
  60.  
  61. ;;;; Compiled Code Entries
  62.  
  63. (define-integrable (compiled-code-address? object)
  64.   (object-type? (ucode-type compiled-entry) object))
  65.  
  66. (define-integrable (stack-address? object)
  67.   (object-type? (ucode-type stack-environment) object))
  68.  
  69. (define (compiled-expression? object)
  70.   (and (compiled-code-address? object)
  71.        (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))
  72.  
  73. (define (compiled-return-address? object)
  74.   (and (compiled-code-address? object)
  75.        (eq? (compiled-entry-type object) 'COMPILED-RETURN-ADDRESS)))
  76.  
  77. (define-primitives
  78.   (stack-address-offset 1)
  79.   (compiled-code-address->block 1)
  80.   (compiled-code-address->offset 1))
  81.  
  82. (define (discriminate-compiled-entry entry
  83.                      if-procedure
  84.                      if-return-address
  85.                      if-expression
  86.                      if-other)
  87.   (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry))
  88.     ((0) (if-procedure))
  89.     ((1) (if-return-address))
  90.     ((2) (if-expression))
  91.     (else (if-other))))
  92.  
  93. (define (compiled-entry-type entry)
  94.   (case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry))
  95.     ((0) 'COMPILED-PROCEDURE)
  96.     ((1) 'COMPILED-RETURN-ADDRESS)
  97.     ((2) 'COMPILED-EXPRESSION)
  98.     (else 'COMPILED-ENTRY)))
  99.  
  100. (define (compiled-continuation/next-continuation-offset entry)
  101.   (let ((offset
  102.      (system-hunk3-cxr2 ((ucode-primitive compiled-entry-kind 1) entry))))
  103.     (and (not (negative? offset))
  104.      offset)))
  105.  
  106. (define (compiled-continuation/return-to-interpreter? entry)
  107.   (let ((kind ((ucode-primitive compiled-entry-kind 1) entry)))
  108.     (and (fix:= (system-hunk3-cxr1 kind) 2)
  109.      (fix:= (system-hunk3-cxr2 kind) 0))))
  110.  
  111. (define (compiled-continuation/reflect-to-interface? entry)
  112.   (let ((kind ((ucode-primitive compiled-entry-kind 1) entry)))
  113.     (and (fix:= (system-hunk3-cxr1 kind) 2)
  114.      (not (fix:= (system-hunk3-cxr2 kind) 0)))))
  115.  
  116. (define (stack-address->index address start-offset)
  117.   (if (not (stack-address? address))
  118.       (error "Not a stack address" address))
  119.   (let ((index (- start-offset (stack-address-offset address))))
  120.     (if (negative? index)
  121.     (error "Stack address out of range" address start-offset))
  122.     index))
  123.  
  124. ;;;; Compiled Code Blocks
  125.  
  126. #|
  127.  
  128. Compiled code blocks contain both nonmarked code and marked constants.
  129.  
  130. Code positions are referred to as OFFSETS, which start from the
  131. beginning of the block and are measured in bytes.  The positions of
  132. constants are referred to as INDICES, and use the normal index
  133. numbering for vectors.  The conversion between offsets and indices is
  134. specified by COMPILED-CODE-BLOCK/BYTES-PER-OBJECT, which should be set
  135. to the correct value before these operations are used.
  136.  
  137. Note: This code needs to be changed somewhat.  MANIFEST-CLOSURES are
  138. compiled-code-blocks, but the format of them is completely different.
  139.  
  140. The constants block in a compiled-code-block often has a linkage
  141. section that you cannot just vector-ref into as it contains raw
  142. amchine addresses.  COMPILED-CODE-BLOCK/MARKED-START returns the start
  143. index of this area.  COMPILED-CODE-BLOCK/CONSTANTS-START returns the
  144. start index of the area following the linkage section, which usually
  145. contains constants derived from the source program.
  146. |#
  147.  
  148. (define compiled-code-block/bytes-per-object)
  149.  
  150. (define-integrable (compiled-code-block? object)
  151.   (object-type? (ucode-type compiled-code-block) object))
  152.  
  153. (define-integrable (compiled-code-block/read-file filename)
  154.   (compiled-code-address->block (fasload filename)))
  155.  
  156. (define (compiled-code-block/manifest-closure? block)
  157.   (object-type? 
  158.    (ucode-type manifest-closure)
  159.    ;; This combination returns an unsafe object, but since it
  160.    ;; is used as an argument to a primitive, I can get away
  161.    ;; with not turning off the garbage collector.
  162.    ((ucode-primitive primitive-object-ref 2) block 0)))
  163.  
  164. (define (compiled-code-block/index->offset index)
  165.   (* (1+ index) compiled-code-block/bytes-per-object))
  166.  
  167. (define (compiled-code-block/offset->index offset)
  168.   (-1+ (quotient offset compiled-code-block/bytes-per-object)))
  169.  
  170. (define (compiled-code-block/code-length block)
  171.   (* compiled-code-block/bytes-per-object
  172.      (object-datum (system-vector-ref block 0))))
  173.  
  174. (define (compiled-code-block/code-start block)
  175.   block
  176.   (* compiled-code-block/bytes-per-object 2))
  177.  
  178. (define (compiled-code-block/code-end block)
  179.   (+ (compiled-code-block/code-start block)
  180.      (compiled-code-block/code-length block)))
  181.  
  182. (define (compiled-code-block/marked-start block)
  183.   ;; The first offset that is a marked constant
  184.   (1+ (object-datum (system-vector-ref block 0))))
  185.  
  186. (define (compiled-code-block/constants-start block)
  187.   ;; Skip over linkage sections and manifect vector templates to find an
  188.   ;; index that can be used to extract constants.
  189.   (let ((marked-start (compiled-code-block/marked-start block))
  190.     (end          (compiled-code-block/constants-end block)))
  191.     (let loop ((index  marked-start))
  192.       (if (>= index end)
  193.       end
  194.       (let ((type  (object-type (system-vector-ref block index)))
  195.         (datum (object-datum (system-vector-ref block index))))
  196.         (cond ((= type (ucode-type manifest-closure))
  197.            (loop (+ index 1 4)))
  198.           ((or (= type (ucode-type linkage-section))   ;; linked or..
  199.                (= type (ucode-type positive-fixnum)))  ;; before linking
  200.            ;; [Before linking the execute caches are headed by fixnums
  201.            ;; and contain symbols and fixnums]
  202.            (let ((kind  (quotient datum #x10000))
  203.              (count (remainder datum #x10000)))
  204.              kind
  205.              (loop (+ index 1 count))))
  206.           (else
  207.            index)))))))
  208.  
  209. (define (compiled-code-block/constants-end block)
  210.   (- (system-vector-length block) 2))
  211.  
  212. (define (compiled-code-block/debugging-info? block)
  213.   (not (memq (compiled-code-block/debugging-info block) '(#F DEBUGGING-INFO))))
  214.  
  215. (define (compiled-code-block/debugging-info block)
  216.   (system-vector-ref block (- (system-vector-length block) 2)))
  217.  
  218. (define (set-compiled-code-block/debugging-info! block info)
  219.   (system-vector-set! block (- (system-vector-length block) 2) info))
  220.  
  221. (define (compiled-code-block/environment block)
  222.   (system-vector-ref block (-1+ (system-vector-length block))))
  223.  
  224. ;;;; Environment Extensions
  225.  
  226. (define-integrable (environment-extension? object)
  227.   (vector? object))
  228.  
  229. (define-integrable (environment-extension-parent extension)
  230.   (vector-ref extension 0))
  231.  
  232. (define-integrable (set-environment-extension-parent! extension parent)
  233.   (vector-set! extension 0 parent))
  234.  
  235. (define-integrable (environment-extension-procedure extension)
  236.   (vector-ref extension 1))
  237.  
  238. (define (environment-extension-aux-list extension)
  239.   (let filter-potentially-dangerous
  240.       ((aux-list
  241.     (let ((first-aux-slot 3))
  242.       (subvector->list
  243.        extension
  244.        first-aux-slot
  245.        (+ first-aux-slot (object-datum (vector-ref extension 2)))))))
  246.     (cond ((null? aux-list) '())
  247.       ((unbound-reference-trap?
  248.         (map-reference-trap (lambda () (cdar aux-list))))
  249.        (filter-potentially-dangerous (cdr aux-list)))
  250.       (else
  251.        (cons (car aux-list)
  252.          (filter-potentially-dangerous (cdr aux-list)))))))
  253.  
  254. ;;;; Promises
  255.  
  256. (define-integrable (promise? object)
  257.   (object-type? (ucode-type delayed) object))
  258.  
  259. (define-integrable (promise-forced? promise)
  260.   (eq? true (system-pair-car promise)))
  261.  
  262. (define-integrable (promise-non-expression? promise)
  263.   (eqv? 0 (system-pair-car promise)))
  264.  
  265. (define (promise-value promise)
  266.   (if (not (promise-forced? promise))
  267.       (error "Promise not yet forced" promise))
  268.   (system-pair-cdr promise))
  269.  
  270. (define (promise-expression promise)
  271.   (if (promise-forced? promise)
  272.       (error "Promise already forced" promise))
  273.   (if (promise-non-expression? promise)
  274.       (error "Promise has no expression" promise))
  275.   (system-pair-cdr promise))
  276.  
  277. (define (promise-environment promise)
  278.   (if (promise-forced? promise)
  279.       (error "Promise already forced" promise))
  280.   (if (promise-non-expression? promise)
  281.       (error "Promise has no environment" promise))
  282.   (system-pair-car promise))
  283.  
  284. (define (force promise)
  285.   (cond ((not (promise? promise))
  286.      (error:wrong-type-argument promise "promise" 'FORCE))
  287.     ((eq? #T (system-pair-car promise))
  288.      (system-pair-cdr promise))
  289.     ((eqv? 0 (system-pair-car promise)) ; compiled promise
  290.      (let ((result ((system-pair-cdr promise))))
  291.        (system-pair-set-cdr! promise result)
  292.        (system-pair-set-car! promise #T)
  293.        result))
  294.     (else ; losing old style
  295.      ((ucode-primitive force 1) promise))))
  296.