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 / compiler / base / infnew.scm < prev    next >
Text File  |  1999-01-02  |  13KB  |  373 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: infnew.scm,v 4.12 1999/01/02 06:06:43 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. ;;;; Debugging Information
  23. ;;; package: (compiler debugging-information)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (info-generation-phase-1 expression procedures)
  28.   (fluid-let ((*integrated-variables* '()))
  29.     (set-expression-debugging-info!
  30.      expression
  31.      (make-dbg-expression (block->dbg-block (expression-block expression))
  32.               (expression-label expression)))
  33.     (for-each
  34.      (lambda (procedure)
  35.        (if (procedure-continuation? procedure)
  36.        (set-continuation/debugging-info!
  37.         procedure
  38.         (let ((block (block->dbg-block (continuation/block procedure))))
  39.           (let ((continuation
  40.              (make-dbg-continuation
  41.               block
  42.               (continuation/label procedure)
  43.               (enumeration/index->name continuation-types
  44.                            (continuation/type procedure))
  45.               (continuation/offset procedure)
  46.               (continuation/debugging-info procedure))))
  47.         (set-dbg-block/procedure! block continuation)
  48.         continuation)))
  49.        (set-procedure-debugging-info!
  50.         procedure
  51.         (let ((block (block->dbg-block (procedure-block procedure))))
  52.           (let ((procedure
  53.              (make-dbg-procedure
  54.               block
  55.               (procedure-label procedure)
  56.               (procedure/type procedure)
  57.               (procedure-name procedure)
  58.               (map variable->dbg-variable
  59.                (cdr (procedure-original-required procedure)))
  60.               (map variable->dbg-variable
  61.                (procedure-original-optional procedure))
  62.               (let ((rest (procedure-original-rest procedure)))
  63.             (and rest (variable->dbg-variable rest)))
  64.               (map variable->dbg-variable (procedure-names procedure))
  65.               (procedure-debugging-info procedure))))
  66.         (set-dbg-block/procedure! block procedure)
  67.         procedure)))))
  68.      procedures)
  69.     (for-each process-integrated-variable! *integrated-variables*)))
  70.  
  71. (define (generated-dbg-continuation context label)
  72.   (let ((block
  73.      (make-dbg-block/continuation (reference-context/block context)
  74.                       false)))
  75.     (let ((continuation
  76.        (make-dbg-continuation block
  77.                   label
  78.                   'GENERATED
  79.                   (reference-context/offset context)
  80.                   false)))
  81.       (set-dbg-block/procedure! block continuation)
  82.       continuation)))
  83.  
  84. (define (block->dbg-block block)
  85.   (and block
  86.        (or (block-debugging-info block)
  87.        (let ((dbg-block
  88.           (enumeration-case block-type (block-type block)
  89.             ((STACK) (stack-block->dbg-block block))
  90.             ((CONTINUATION) (continuation-block->dbg-block block))
  91.             ((CLOSURE) (closure-block->dbg-block block))
  92.             ((IC) (ic-block->dbg-block block))
  93.             (else
  94.              (error "BLOCK->DBG-BLOCK: Illegal block type" block)))))
  95.          (set-block-debugging-info! block dbg-block)
  96.          dbg-block))))
  97.  
  98. (define (stack-block->dbg-block block)
  99.   (let ((parent (block-parent block))
  100.     (frame-size (block-frame-size block))
  101.     (procedure (block-procedure block)))
  102.     (let ((layout (make-layout frame-size)))
  103.       (for-each (lambda (variable)
  104.           (if (not (continuation-variable? variable))
  105.               (layout-set! layout
  106.                    (variable-normal-offset variable)
  107.                    (variable->dbg-variable variable))))
  108.         (block-bound-variables block))
  109.       (if (procedure/closure? procedure)
  110.       (if (closure-procedure-needs-operator? procedure)
  111.           (layout-set! layout
  112.                (procedure-closure-offset procedure)
  113.                dbg-block-name/normal-closure))
  114.       (if (stack-block/static-link? block)
  115.           (layout-set! layout
  116.                (-1+ frame-size)
  117.                dbg-block-name/static-link)))
  118.       (make-dbg-block 'STACK
  119.               (block->dbg-block parent)
  120.               (if (procedure/closure? procedure)
  121.               (block->dbg-block
  122.                (reference-context/block
  123.                 (procedure-closure-context procedure)))
  124.               (block->dbg-block
  125.                (procedure-target-block procedure)))
  126.               layout
  127.               (block->dbg-block (block-stack-link block))))))
  128.  
  129. (define (continuation-block->dbg-block block)
  130.   (make-dbg-block/continuation
  131.    (block-parent block)
  132.    (continuation/always-known-operator? (block-procedure block))))
  133.  
  134. (define (make-dbg-block/continuation parent always-known?)
  135.   (let ((dbg-parent (block->dbg-block parent)))
  136.     (make-dbg-block
  137.      'CONTINUATION
  138.      dbg-parent
  139.      false
  140.      (let ((names
  141.         (append (if always-known?
  142.             '()
  143.             (list dbg-block-name/return-address))
  144.             (if (block/dynamic-link? parent)
  145.             (list dbg-block-name/dynamic-link)
  146.             '())
  147.             (if (ic-block? parent)
  148.             (list dbg-block-name/ic-parent)
  149.             '()))))
  150.        (let ((layout (make-layout (length names))))
  151.      (do ((names names (cdr names))
  152.           (index 0 (1+ index)))
  153.          ((null? names))
  154.        (layout-set! layout index (car names)))
  155.      layout))
  156.      dbg-parent)))
  157.  
  158. (define (closure-block->dbg-block block)
  159.   (let ((parent (block-parent block))
  160.     (start-offset
  161.      (closure-object-first-offset
  162.       (block-entry-number (block-shared-block block))))
  163.     (offsets
  164.      (map (lambda (offset)
  165.         (cons (car offset)
  166.               (- (cdr offset)
  167.              (closure-block-first-offset block))))
  168.           (block-closure-offsets block))))
  169.     (let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
  170.       (for-each (lambda (offset)
  171.           (layout-set! layout
  172.                    (cdr offset)
  173.                    (variable->dbg-variable (car offset))))
  174.         offsets)
  175.       (if (and parent (ic-block/use-lookup? parent))
  176.       (layout-set! layout 0 dbg-block-name/ic-parent))
  177.       (make-dbg-block 'CLOSURE (block->dbg-block parent) false
  178.               (cons start-offset layout)
  179.               false))))
  180.  
  181. (define (ic-block->dbg-block block)
  182.   (make-dbg-block 'IC (block->dbg-block (block-parent block))
  183.           false false false))
  184.  
  185. (define-integrable (make-layout length)
  186.   (make-vector length false))
  187.  
  188. (define (layout-set! layout index name)
  189.   (let ((name* (vector-ref layout index)))
  190.     (if name* (error "LAYOUT-SET!: reusing layout slot" name* name)))
  191.   (vector-set! layout index name)
  192.   unspecific)
  193.  
  194. (define *integrated-variables*)
  195.  
  196. (define (variable->dbg-variable variable)
  197.   (or (lvalue-get variable dbg-variable-tag)
  198.       (let ((integrated? (lvalue-integrated? variable))
  199.         (indirection (variable-indirection variable)))
  200.     (let ((dbg-variable
  201.            (make-dbg-variable
  202.         (variable-name variable)
  203.         (cond (integrated? 'INTEGRATED)
  204.               (indirection 'INDIRECTED)
  205.               ((variable-in-cell? variable) 'CELL)
  206.               (else 'NORMAL))
  207.         (cond (integrated?
  208.                (lvalue-known-value variable))
  209.               (indirection
  210.                ;; This currently does not examine whether it is a
  211.                ;; simple indirection, or a closure indirection.
  212.                ;; The value displayed will be incorrect if it
  213.                ;; is a closure indirection, but...
  214.                (variable->dbg-variable (car indirection)))
  215.               (else
  216.                false)))))
  217.       (if integrated?
  218.           (set! *integrated-variables*
  219.             (cons dbg-variable *integrated-variables*)))
  220.       (lvalue-put! variable dbg-variable-tag dbg-variable)
  221.       dbg-variable))))
  222.  
  223. (define dbg-variable-tag
  224.   "dbg-variable-tag")
  225.  
  226. (define (process-integrated-variable! variable)
  227.   (set-dbg-variable/value!
  228.    variable
  229.    (let ((rvalue (dbg-variable/value variable)))
  230.      (cond ((rvalue/constant? rvalue) (constant-value rvalue))
  231.        ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue))
  232.        (else (error "Illegal variable value" rvalue))))))
  233.  
  234. (define (info-generation-phase-2 expression procedures continuations)
  235.   (let ((debug-info
  236.      (lambda (selector object)
  237.        (or (selector object)
  238.            (error "Missing debugging info" object)))))
  239.     (values
  240.      (and expression (debug-info rtl-expr/debugging-info expression))
  241.      (map (lambda (procedure)
  242.         (let ((info (debug-info rtl-procedure/debugging-info procedure)))
  243.           (set-dbg-procedure/external-label!
  244.            info
  245.            (rtl-procedure/%external-label procedure))
  246.           info))
  247.       procedures)
  248.      (map (lambda (continuation)
  249.         (debug-info rtl-continuation/debugging-info continuation))
  250.       continuations))))
  251.  
  252. (define (info-generation-phase-3 expression procedures continuations
  253.                  label-bindings external-labels)
  254.   (let ((label-bindings (labels->dbg-labels label-bindings))
  255.     (no-datum '(NO-DATUM)))
  256.     (let ((labels (make-string-hash-table)))
  257.       (for-each (lambda (label-binding)
  258.           (for-each (lambda (key)
  259.                   (let ((datum
  260.                      (hash-table/get labels key no-datum)))
  261.                 (if (not (eq? datum no-datum))
  262.                     (error "Redefining label:" key datum)))
  263.                   (hash-table/put! labels
  264.                            key
  265.                            (cdr label-binding)))
  266.                 (car label-binding)))
  267.         label-bindings)
  268.       (let ((map-label/fail
  269.          (lambda (label)
  270.            (let ((key (system-pair-car label)))
  271.          (let ((datum (hash-table/get labels key no-datum)))
  272.            (if (eq? datum no-datum)
  273.                (error "Missing label:" key))
  274.            datum))))
  275.         (map-label/false
  276.          (lambda (label)
  277.            (hash-table/get labels (system-pair-car label) #f))))
  278.     (for-each (lambda (label)
  279.             (set-dbg-label/external?! (map-label/fail label) true))
  280.           external-labels)
  281.     (if expression
  282.         (set-dbg-expression/label!
  283.          expression
  284.          (map-label/fail (dbg-expression/label expression))))
  285.     (for-each
  286.      (lambda (procedure)
  287.        (let* ((internal-label (dbg-procedure/label procedure))
  288.           (mapped-label (map-label/false internal-label)))
  289.          (set-dbg-procedure/label! procedure mapped-label)
  290.          (cond ((dbg-procedure/external-label procedure)
  291.             => (lambda (label)
  292.              (set-dbg-procedure/external-label!
  293.               procedure
  294.               (map-label/fail label))))
  295.            ((not mapped-label)
  296.             (error "Missing label" internal-label)))))
  297.      procedures)
  298.     (for-each
  299.      (lambda (continuation)
  300.        (set-dbg-continuation/label!
  301.         continuation
  302.         (map-label/fail (dbg-continuation/label continuation))))
  303.      continuations)))
  304.     (make-dbg-info
  305.      expression
  306.      (list->vector (sort procedures dbg-procedure<?))
  307.      (list->vector (sort continuations dbg-continuation<?))
  308.      (list->vector (map cdr label-bindings)))))
  309.  
  310. (define (labels->dbg-labels label-bindings)
  311.   (map (lambda (offset-binding)
  312.      (let ((names (cdr offset-binding)))
  313.        (cons names
  314.          (make-dbg-label-2 (choose-distinguished-label names)
  315.                    (car offset-binding)))))
  316.        (let ((offsets (make-rb-tree = <)))
  317.      (for-each (lambda (binding)
  318.              (let ((offset (cdr binding))
  319.                (name (system-pair-car (car binding))))
  320.                (let ((datum (rb-tree/lookup offsets offset #f)))
  321.              (if datum
  322.                  (set-cdr! datum (cons name (cdr datum)))
  323.                  (rb-tree/insert! offsets offset (list name))))))
  324.            label-bindings)
  325.      (rb-tree->alist offsets))))
  326.  
  327. (define (choose-distinguished-label names)
  328.   (if (null? (cdr names))
  329.       (car names)
  330.       (let ((distinguished
  331.          (list-transform-negative names
  332.            (lambda (name)
  333.          (or (standard-name? name "label")
  334.              (standard-name? name "end-label"))))))
  335.     (cond ((null? distinguished)
  336.            (min-suffix names))
  337.           ((null? (cdr distinguished))
  338.            (car distinguished))
  339.           (else
  340.            (min-suffix distinguished))))))
  341.  
  342. (define char-set:label-separators
  343.   (char-set #\- #\_))
  344.  
  345. (define (min-suffix names)
  346.   (let ((suffix-number
  347.      (lambda (name)
  348.        (let ((index (string-find-previous-char-in-set
  349.              name
  350.              char-set:label-separators)))
  351.          (if (not index)
  352.          (error "Illegal label name" name))
  353.          (let ((suffix (string-tail name (1+ index))))
  354.            (let ((result (string->number suffix)))
  355.          (if (not result)
  356.              (error "Illegal label suffix" suffix))
  357.          result))))))
  358.     (car (sort names (lambda (x y)
  359.                (< (suffix-number x)
  360.               (suffix-number y)))))))
  361.  
  362. (define (standard-name? string prefix)
  363.   (let ((index (string-match-forward-ci string prefix))
  364.     (end (string-length string)))
  365.     (and (= index (string-length prefix))
  366.      (>= (- end index) 2)
  367.      (let ((next (string-ref string index)))
  368.        (or (char=? #\- next)
  369.            (char=? #\_ next)))
  370.      (let loop ((index (1+ index)))
  371.        (or (= index end)
  372.            (and (char-numeric? (string-ref string index))
  373.             (loop (1+ index))))))))