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 / conpar.scm < prev    next >
Text File  |  1999-02-24  |  38KB  |  1,031 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: conpar.scm,v 14.38 1999/02/24 21:23:46 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. ;;;; Continuation Parser
  23. ;;; package: (runtime continuation-parser)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Stack Frames
  28.  
  29. (define-structure (stack-frame
  30.            (constructor make-stack-frame
  31.                 (type elements dynamic-state
  32.                       block-thread-events?
  33.                       interrupt-mask history
  34.                       previous-history-offset
  35.                       previous-history-control-point
  36.                       offset previous-type %next))
  37.            (conc-name stack-frame/))
  38.   (type #f read-only #t)
  39.   (elements #f read-only #t)
  40.   (dynamic-state #f read-only #t)
  41.   (block-thread-events? #f read-only #t)
  42.   (interrupt-mask #f read-only #t)
  43.   (history #f read-only #t)
  44.   (previous-history-offset #f read-only #t)
  45.   (previous-history-control-point #f read-only #t)
  46.   (offset #f read-only #t)
  47.   ;; PREVIOUS-TYPE is the stack-frame-type of the frame above this one
  48.   ;; on the stack (closer to the stack's top).  In at least two cases
  49.   ;; we need to know this information.
  50.   (previous-type #f read-only #t)
  51.   ;; %NEXT is either a parser-state object or the next frame.  In the
  52.   ;; former case, the parser-state is used to compute the next frame.
  53.   %next
  54.   (properties (make-1d-table) read-only #t))
  55.  
  56. (define (stack-frame/reductions stack-frame)
  57.   (let ((history (stack-frame/history stack-frame)))
  58.     (if (eq? history undefined-history)
  59.     '()
  60.     (history-reductions history))))
  61.  
  62. (define undefined-history
  63.   "no history")
  64.  
  65. (define (stack-frame/next stack-frame)
  66.   (let ((next (stack-frame/%next stack-frame)))
  67.     (if (parser-state? next)
  68.     (let ((next (parse-one-frame next)))
  69.       (set-stack-frame/%next! stack-frame next)
  70.       next)
  71.     next)))
  72.  
  73. (define-integrable (continuation/first-subproblem continuation)
  74.   (stack-frame/skip-non-subproblems (continuation->stack-frame continuation)))
  75.  
  76. (define (stack-frame/next-subproblem stack-frame)
  77.   (if (stack-frame/subproblem? stack-frame)
  78.       (let ((stack-frame (stack-frame/next stack-frame)))
  79.     (and stack-frame
  80.          (stack-frame/skip-non-subproblems stack-frame)))
  81.       (stack-frame/skip-non-subproblems stack-frame)))
  82.  
  83. (define-integrable (stack-frame/length stack-frame)
  84.   (vector-length (stack-frame/elements stack-frame)))
  85.  
  86. (define (stack-frame/ref stack-frame index)
  87.   (let ((elements (stack-frame/elements stack-frame)))
  88.     (let ((length (vector-length elements)))
  89.       (if (< index length)
  90.       (map-reference-trap (lambda () (vector-ref elements index)))
  91.       (stack-frame/ref (stack-frame/next stack-frame) (- index length))))))
  92.  
  93. (define-integrable (stack-frame/return-address stack-frame)
  94.   (stack-frame/ref stack-frame 0))
  95.  
  96. (define (stack-frame/return-code stack-frame)
  97.   (let ((return-address (stack-frame/return-address stack-frame)))
  98.     (and (interpreter-return-address? return-address)
  99.      (return-address/code return-address))))
  100.  
  101. (define-integrable (stack-frame/compiled-code? stack-frame)
  102.   (compiled-return-address? (stack-frame/return-address stack-frame)))
  103.  
  104. (define (stack-frame/subproblem? stack-frame)
  105.   (if (stack-frame/stack-marker? stack-frame)
  106.       (stack-marker-frame/repl-eval-boundary? stack-frame)
  107.       (stack-frame-type/subproblem? (stack-frame/type stack-frame))))
  108.  
  109. (define (stack-frame/resolve-stack-address frame address)
  110.   (let loop
  111.       ((frame frame)
  112.        (offset (stack-address->index address (stack-frame/offset frame))))
  113.     (let ((length (stack-frame/length frame)))
  114.       (if (< offset length)
  115.       (values frame offset)
  116.       (loop (stack-frame/next frame) (- offset length))))))
  117.  
  118. (define (stack-frame/skip-non-subproblems stack-frame)
  119.   (let ((type (stack-frame/type stack-frame)))
  120.     (cond ((and (stack-frame/subproblem? stack-frame)
  121.         (not (and (eq? type stack-frame-type/compiled-return-address)
  122.               (eq? (stack-frame/return-address stack-frame)
  123.                    continuation-return-address))))
  124.        stack-frame)
  125.       ((stack-frame/stack-marker? stack-frame)
  126.        (let loop ((stack-frame stack-frame))
  127.          (let ((stack-frame (stack-frame/next stack-frame)))
  128.            (and stack-frame
  129.             (if (stack-frame/subproblem? stack-frame)
  130.             (stack-frame/next-subproblem stack-frame)
  131.             (loop stack-frame))))))
  132.       (else
  133.        (let ((stack-frame (stack-frame/next stack-frame)))
  134.          (and stack-frame
  135.           (stack-frame/skip-non-subproblems stack-frame)))))))
  136.  
  137. (define continuation-return-address)
  138.  
  139. (define (initialize-special-frames!)
  140.   (set! continuation-return-address
  141.     (let ((stack-frame
  142.            (call-with-current-continuation
  143.         (lambda (k)
  144.           k
  145.           (call-with-current-continuation
  146.            continuation/first-subproblem)))))
  147.       (and (eq? (stack-frame/type stack-frame)
  148.             stack-frame-type/compiled-return-address)
  149.            (stack-frame/return-address stack-frame))))
  150.   unspecific)
  151.  
  152. ;;;; Parser
  153.  
  154. (define-structure (parser-state (constructor make-parser-state)
  155.                 (conc-name parser-state/))
  156.   (dynamic-state #f read-only #t)
  157.   (block-thread-events? #f read-only #t)
  158.   (interrupt-mask #f read-only #t)
  159.   (history #f read-only #t)
  160.   (previous-history-offset #f read-only #t)
  161.   (previous-history-control-point #f read-only #t)
  162.   (element-stream #f read-only #t)
  163.   (n-elements #f read-only #t)
  164.   (next-control-point #f read-only #t)
  165.   (previous-type #f read-only #t))
  166.  
  167. (define (continuation->stack-frame continuation)
  168.   (parse-control-point (continuation/control-point continuation)
  169.                (continuation/dynamic-state continuation)
  170.                (continuation/block-thread-events? continuation)
  171.                #f))
  172.  
  173. (define (parse-control-point control-point dynamic-state block-thread-events?
  174.                  type)
  175.   (let ((element-stream (control-point/element-stream control-point)))
  176.     (parse-one-frame
  177.      (make-parser-state
  178.       dynamic-state
  179.       block-thread-events?
  180.       (control-point/interrupt-mask control-point)
  181.       (let ((history
  182.          (history-transform (control-point/history control-point))))
  183.     (if (and (stream-pair? element-stream)
  184.          (eq? return-address/reenter-compiled-code
  185.               (element-stream/head element-stream)))
  186.         history
  187.         (history-superproblem history)))
  188.       (control-point/previous-history-offset control-point)
  189.       (control-point/previous-history-control-point control-point)
  190.       element-stream
  191.       (control-point/n-elements control-point)
  192.       (control-point/next-control-point control-point)
  193.       type))))
  194.  
  195. (define (parse-one-frame state)
  196.   (define (handle-ordinary stream)
  197.     (let ((type
  198.        (return-address->stack-frame-type
  199.         (element-stream/head stream)
  200.         (let ((type (parser-state/previous-type state)))
  201.           (and type
  202.            (1d-table/get (stack-frame-type/properties type)
  203.                  allow-extended?-tag
  204.                  #f))))))
  205.       (let ((length
  206.          (let ((length (stack-frame-type/length type)))
  207.            (if (exact-nonnegative-integer? length)
  208.            length
  209.            (length stream (parser-state/n-elements state))))))
  210.     ((stack-frame-type/parser type)
  211.      type
  212.      (list->vector (stream-head stream length))
  213.      (make-intermediate-state state length (stream-tail stream length))))))
  214.  
  215.   (let ((the-stream (parser-state/element-stream state)))
  216.     (if (stream-pair? the-stream)
  217.     (handle-ordinary the-stream)
  218.     (let ((control-point (parser-state/next-control-point state)))
  219.       (and control-point
  220.            (if (not (zero? (parser-state/n-elements state)))
  221.            ;; Construct invisible join-stacklets frame.
  222.            (handle-ordinary
  223.             (stream return-address/join-stacklets control-point))
  224.            (parse-control-point
  225.             control-point
  226.             (parser-state/dynamic-state state)
  227.             (parser-state/block-thread-events? state)
  228.             (parser-state/previous-type state))))))))
  229.  
  230. ;;; `make-intermediate-state' is used to construct an intermediate
  231. ;;; parser state that is passed to the frame parser.  This
  232. ;;; intermediate state is identical to `state' except that it shows
  233. ;;; `length' items having been removed from the stream.
  234.  
  235. (define (make-intermediate-state state length stream)
  236.   (let ((previous-history-control-point
  237.      (parser-state/previous-history-control-point state))
  238.     (new-length
  239.      (- (parser-state/n-elements state) length)))
  240.     (make-parser-state
  241.      (parser-state/dynamic-state state)
  242.      (parser-state/block-thread-events? state)
  243.      (parser-state/interrupt-mask state)
  244.      (parser-state/history state)
  245.      (let ((previous (parser-state/previous-history-offset state)))
  246.        (if (or previous-history-control-point
  247.            (>= new-length previous))
  248.        previous
  249.        0))
  250.      previous-history-control-point
  251.      stream
  252.      new-length
  253.      (parser-state/next-control-point state)
  254.      (parser-state/previous-type state))))
  255.  
  256. ;;; After each frame parser is done, it either tail recurses into the
  257. ;;; parsing loop, or it calls `parser/standard' to produces a new
  258. ;;; output frame.  The argument `state' is usually what was passed to
  259. ;;; the frame parser (i.e. the state that was returned by the previous
  260. ;;; call to `make-intermediate-state').  However, several of the
  261. ;;; parsers change the values of some of the components of `state'
  262. ;;; before calling `parser/standard' -- for example,
  263. ;;; RESTORE-INTERRUPT-MASK changes the `interrupt-mask' component.
  264.  
  265. (define (parse/standard-next type elements state history? force-pop?)
  266.   (let ((n-elements (parser-state/n-elements state))
  267.     (history-subproblem?
  268.      (stack-frame-type/history-subproblem? type))
  269.     (history (parser-state/history state))
  270.     (previous-history-offset (parser-state/previous-history-offset state))
  271.     (previous-history-control-point
  272.      (parser-state/previous-history-control-point state)))
  273.     (make-stack-frame
  274.      type
  275.      elements
  276.      (parser-state/dynamic-state state)
  277.      (parser-state/block-thread-events? state)
  278.      (parser-state/interrupt-mask state)
  279.      (if history?
  280.      history
  281.      undefined-history)
  282.      previous-history-offset
  283.      previous-history-control-point
  284.      (+ (vector-length elements) n-elements)
  285.      (parser-state/previous-type state)
  286.      (make-parser-state (parser-state/dynamic-state state)
  287.             (parser-state/block-thread-events? state)
  288.             (parser-state/interrupt-mask state)
  289.             (if (or force-pop? history-subproblem?)
  290.                 (history-superproblem history)
  291.                 history)
  292.             previous-history-offset
  293.             previous-history-control-point
  294.             (parser-state/element-stream state)
  295.             n-elements
  296.             (parser-state/next-control-point state)
  297.             type))))
  298.  
  299. (define (parser/standard type elements state)
  300.   (parse/standard-next type elements state
  301.                (and (stack-frame-type/history-subproblem? type)
  302.                 (stack-frame-type/subproblem? type))
  303.                #f))
  304.  
  305. (define (parser/standard-compiled type elements state)
  306.   (parse/standard-next
  307.    type elements state
  308.    (let ((stream (parser-state/element-stream state)))
  309.      (and (stream-pair? stream)
  310.       (eq? (return-address->stack-frame-type (element-stream/head stream)
  311.                          #t)
  312.            stack-frame-type/return-to-interpreter)))
  313.    #f))
  314.  
  315. (define (parser/apply type elements state)
  316.   (let ((valid-history?
  317.      (not (let ((stream (parser-state/element-stream state)))
  318.         (and (stream-pair? stream)
  319.              (eq? return-address/reenter-compiled-code
  320.               (element-stream/head stream)))))))
  321.     (parse/standard-next type elements state valid-history? valid-history?)))
  322.  
  323. (define (parser/restore-interrupt-mask type elements state)
  324.   (parser/standard
  325.    type
  326.    elements
  327.    (make-parser-state (parser-state/dynamic-state state)
  328.               (parser-state/block-thread-events? state)
  329.               (vector-ref elements 1)
  330.               (parser-state/history state)
  331.               (parser-state/previous-history-offset state)
  332.               (parser-state/previous-history-control-point state)
  333.               (parser-state/element-stream state)
  334.               (parser-state/n-elements state)
  335.               (parser-state/next-control-point state)
  336.               (parser-state/previous-type state))))
  337.  
  338. (define (parser/restore-history type elements state)
  339.   (parser/standard
  340.    type
  341.    elements
  342.    (make-parser-state (parser-state/dynamic-state state)
  343.               (parser-state/block-thread-events? state)
  344.               (parser-state/interrupt-mask state)
  345.               (history-transform (vector-ref elements 1))
  346.               (vector-ref elements 2)
  347.               (vector-ref elements 3)
  348.               (parser-state/element-stream state)
  349.               (parser-state/n-elements state)
  350.               (parser-state/next-control-point state)
  351.               (parser-state/previous-type state))))
  352.  
  353. (define-integrable code/special-compiled/internal-apply 0)
  354. (define-integrable code/special-compiled/restore-interrupt-mask 1)
  355. (define-integrable code/special-compiled/stack-marker 2)
  356. (define-integrable code/special-compiled/compiled-code-bkpt 3)
  357. (define-integrable code/interrupt-restart 4)
  358. (define-integrable code/restore-regs 5)
  359. (define-integrable code/apply-compiled 6)
  360. (define-integrable code/continue-linking 7)
  361.  
  362. (define (parser/special-compiled type elements state)
  363.   (let ((code (vector-ref elements 1)))
  364.     (cond ((fix:= code code/special-compiled/internal-apply)
  365.        (parse/standard-next type elements state #f #f))
  366.       ((fix:= code code/special-compiled/restore-interrupt-mask)
  367.        (parser/%stack-marker (parser-state/dynamic-state state)
  368.                  (parser-state/block-thread-events? state)
  369.                  (vector-ref elements 2)
  370.                  type elements state))
  371.       ((fix:= code code/special-compiled/stack-marker)
  372.        (parser/stack-marker type elements state))
  373.       ((or (fix:= code code/special-compiled/compiled-code-bkpt)
  374.            (fix:= code code/interrupt-restart)
  375.            (fix:= code code/restore-regs)
  376.            (fix:= code code/apply-compiled)
  377.            (fix:= code code/continue-linking))
  378.        (parse/standard-next type elements state #f #f))
  379.       (else
  380.        (error "Unknown special compiled frame" code)))))
  381.  
  382. (define (parser/stack-marker type elements state)
  383.   (call-with-values
  384.       (lambda ()
  385.     (if (eq? type stack-frame-type/stack-marker)
  386.         (values (vector-ref elements 1) (vector-ref elements 2))
  387.         (values (vector-ref elements 2) (vector-ref elements 3))))
  388.     (lambda (marker-type marker-instance)
  389.       (let ((continue
  390.          (lambda (dynamic-state block-thread-events? interrupt-mask)
  391.            (parser/%stack-marker dynamic-state block-thread-events?
  392.                      interrupt-mask type elements state))))
  393.     (cond ((eq? marker-type %translate-to-state-point)
  394.            (continue (merge-dynamic-state
  395.               (parser-state/dynamic-state state)
  396.               marker-instance)
  397.              (parser-state/block-thread-events? state)
  398.              (parser-state/interrupt-mask state)))
  399.           ((eq? marker-type set-interrupt-enables!)
  400.            (continue (parser-state/dynamic-state state)
  401.              (parser-state/block-thread-events? state)
  402.              marker-instance))
  403.           ((eq? marker-type with-thread-events-blocked)
  404.            (continue (parser-state/dynamic-state state)
  405.              marker-instance
  406.              (parser-state/interrupt-mask state)))
  407.           (else
  408.            (continue (parser-state/dynamic-state state)
  409.              (parser-state/block-thread-events? state)
  410.              (parser-state/interrupt-mask state))))))))
  411.  
  412. (define (parser/%stack-marker dynamic-state block-thread-events? interrupt-mask
  413.                   type elements state)
  414.   (parser/standard
  415.    type
  416.    elements
  417.    (make-parser-state dynamic-state
  418.               block-thread-events?
  419.               interrupt-mask
  420.               (parser-state/history state)
  421.               (parser-state/previous-history-offset state)
  422.               (parser-state/previous-history-control-point state)
  423.               (parser-state/element-stream state)
  424.               (parser-state/n-elements state)
  425.               (parser-state/next-control-point state)
  426.               (parser-state/previous-type state))))
  427.  
  428. (define (stack-frame/stack-marker? stack-frame)
  429.   (or (%stack-frame/stack-marker? stack-frame)
  430.       (and (stack-frame/special-compiled? stack-frame)
  431.        (let ((code (vector-ref (stack-frame/elements stack-frame) 1)))
  432.          (or (fix:= code/special-compiled/restore-interrupt-mask code)
  433.          (fix:= code/special-compiled/stack-marker code))))))
  434.  
  435. (define (stack-marker-frame/type stack-frame)
  436.   (if (%stack-frame/stack-marker? stack-frame)
  437.       (vector-ref (stack-frame/elements stack-frame) 1)
  438.       (vector-ref (stack-frame/elements stack-frame) 2)))
  439.  
  440. (define (stack-marker-frame/instance stack-frame)
  441.   (if (%stack-frame/stack-marker? stack-frame)
  442.       (vector-ref (stack-frame/elements stack-frame) 2)
  443.       (vector-ref (stack-frame/elements stack-frame) 3)))
  444.  
  445. (define-integrable (%stack-frame/stack-marker? stack-frame)
  446.   (eq? stack-frame-type/stack-marker (stack-frame/type stack-frame)))
  447.  
  448. (define-integrable (stack-frame/special-compiled? stack-frame)
  449.   (eq? stack-frame-type/special-compiled (stack-frame/type stack-frame)))
  450.  
  451. (define (stack-frame/repl-eval-boundary? stack-frame)
  452.   (and (stack-frame/stack-marker? stack-frame)
  453.        (stack-marker-frame/repl-eval-boundary? stack-frame)))
  454.  
  455. (define-integrable (stack-marker-frame/repl-eval-boundary? stack-frame)
  456.   (eq? with-repl-eval-boundary (stack-marker-frame/type stack-frame)))
  457.  
  458. ;;;; Unparser
  459.  
  460. (define (stack-frame->continuation stack-frame)
  461.   (make-continuation 'REENTRANT
  462.              (stack-frame->control-point stack-frame)
  463.              (stack-frame/dynamic-state stack-frame)
  464.              #f))
  465.  
  466. (define (stack-frame->control-point stack-frame)
  467.   (with-values (lambda () (unparse/stack-frame stack-frame))
  468.     (lambda (element-stream next-control-point)
  469.       (make-control-point
  470.        #f
  471.        0
  472.        (stack-frame/interrupt-mask stack-frame)
  473.        (let ((history (stack-frame/history stack-frame)))
  474.      (if (eq? history undefined-history)
  475.          (fixed-objects-item 'DUMMY-HISTORY)
  476.          (history-untransform history)))
  477.        (stack-frame/previous-history-offset stack-frame)
  478.        (stack-frame/previous-history-control-point stack-frame)
  479.        (if (stack-frame/compiled-code? stack-frame)
  480.        (cons-stream return-address/reenter-compiled-code
  481.             (cons-stream #f element-stream))
  482.        element-stream)
  483.        next-control-point))))
  484.  
  485. (define (unparse/stack-frame stack-frame)
  486.   (if (eq? (stack-frame/return-address stack-frame)
  487.        return-address/join-stacklets)
  488.       (values (stream) (vector-ref (stack-frame/elements stack-frame) 1))
  489.       (with-values
  490.       (lambda ()
  491.         (let ((next (stack-frame/%next stack-frame)))
  492.           (cond ((stack-frame? next)
  493.              (unparse/stack-frame next))
  494.             ((parser-state? next)
  495.              (values (parser-state/element-stream next)
  496.                  (parser-state/next-control-point next)))
  497.             (else
  498.              (values (stream) #f)))))
  499.     (lambda (element-stream next-control-point)
  500.       (values
  501.        (let ((elements (stack-frame/elements stack-frame)))
  502.          (let ((length (vector-length elements)))
  503.            (let loop ((index 0))
  504.          (if (< index length)
  505.              (cons-stream (vector-ref elements index)
  506.                   (loop (1+ index)))
  507.              element-stream))))
  508.        next-control-point)))))
  509.  
  510. (define return-address/join-stacklets)
  511. (define return-address/reenter-compiled-code)
  512.  
  513. ;;;; Special Frame Lengths
  514.  
  515. (define (length/combination-save-value stream offset)
  516.   offset
  517.   (+ 3 (system-vector-length (element-stream/ref stream 1))))
  518.  
  519. (define ((length/application-frame index missing) stream offset)
  520.   offset
  521.   (+ index 1 (- (object-datum (element-stream/ref stream index)) missing)))
  522.  
  523. (define (length/compiled-return-address stream offset)
  524.   (let ((entry (element-stream/head stream)))
  525.     (let ((frame-size (compiled-continuation/next-continuation-offset entry)))
  526.       (if frame-size
  527.       (1+ frame-size)
  528.       (stack-address->index (element-stream/ref stream 1) offset)))))
  529.  
  530. (define (length/special-compiled stream offset)
  531.   ;; return address is reflect-to-interface
  532.   offset
  533.   (let ((code (element-stream/ref stream 1)))
  534.     (define (default)
  535.       (error "length/special-compiled: Unknown code" code))
  536.  
  537.     (cond ((not (fix:fixnum? code))
  538.        (default))
  539.       ((fix:= code code/special-compiled/internal-apply)
  540.        ;; Very infrequent!
  541.        (fix:+ 3 (object-datum (element-stream/ref stream 2))))
  542.       ((fix:= code code/special-compiled/restore-interrupt-mask)
  543.        3)
  544.       ((fix:= code code/special-compiled/stack-marker)
  545.        4)
  546.       ((fix:= code code/special-compiled/compiled-code-bkpt)
  547.        ;; Very infrequent!
  548.        (let ((fsize
  549.           (compiled-code-address/frame-size
  550.            (element-stream/ref stream 2))))
  551.          (if (not fsize)
  552.          5
  553.          (fix:+ 5 fsize))))
  554.       ((fix:= code code/interrupt-restart)
  555.        (if (fix:= 12 microcode-id/version)
  556.            4
  557.            (let ((homes-saved (object-datum (element-stream/ref stream 2)))
  558.              (regs-saved (object-datum (element-stream/ref stream 3))))
  559.          ;; The first reg saved is _always_ the continuation,
  560.          ;; part of the next frame.
  561.          (fix:- (fix:+
  562.              ;; Return code, reflect code, homes saved, regs saved,
  563.              ;; and entry point
  564.              5
  565.              (fix:+ homes-saved regs-saved))
  566.             1))))
  567.       ((fix:= code code/restore-regs)
  568.        (fix:+ 3 (object-datum (element-stream/ref stream 2))))
  569.       ((fix:= code code/apply-compiled)
  570.        ;; Stream[2] is code entry point, [3] is frame size
  571.        (+ 3 (object-datum (element-stream/ref stream 3))))
  572.       ((fix:= code code/continue-linking)
  573.        ;; return code, reflect code, entry size, original count,
  574.        ;; block, environment, offset, last header offset,sections,
  575.        ;; return address
  576.        (fix:- 10 1))
  577.       (else
  578.        (default)))))
  579.  
  580. (define (length/interrupt-compiled-procedure stream offset)
  581.   offset                ; ignored
  582.   (1+ (compiled-procedure-frame-size (element-stream/head stream))))
  583.  
  584. (define (compiled-code-address/frame-size cc-address)
  585.   (cond ((not (compiled-code-address? cc-address))
  586.      (error "compiled-code-address/frame-size: Unexpected object"
  587.         cc-address))
  588.     ((compiled-return-address? cc-address)
  589.      (let ((offset
  590.         (compiled-continuation/next-continuation-offset cc-address)))
  591.        (and offset
  592.         (fix:+ offset 1))))
  593.     ((compiled-procedure? cc-address)
  594.      (fix:+ (compiled-procedure-frame-size cc-address) 1))
  595.     (else
  596.      (error "compiled-code-address/frame-size: Unexpected object"
  597.         cc-address))))
  598.  
  599. (define (verify paranoia-index stream offset)
  600.   (or (zero? paranoia-index)
  601.       (stream-null? stream)
  602.       (let* ((type
  603.           (return-address->stack-frame-type (element-stream/head stream)
  604.                         #f))
  605.          (length
  606.           (let ((length (stack-frame-type/length type)))
  607.         (if (exact-nonnegative-integer? length)
  608.             length
  609.             (length stream offset))))
  610.          (ltail (stream-tail* stream length)))
  611.     (and ltail
  612.          (return-address? (element-stream/head ltail))
  613.          (verify (-1+ paranoia-index)
  614.              ltail
  615.              (+ offset length))))))
  616.  
  617. (define (stream-tail* stream n)
  618.   (cond ((or (zero? n) (stream-null? stream))
  619.      stream)
  620.     ((stream-pair? stream)
  621.      (stream-tail* (stream-cdr stream) (-1+ n)))
  622.     (else
  623.      (error "stream-tail*: not a proper stream" stream))))
  624.  
  625. (define (element-stream/head stream)
  626.   (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
  627.   (map-reference-trap (lambda () (stream-car stream))))
  628.  
  629. (define-integrable (element-stream/ref stream index)
  630.   (map-reference-trap (lambda () (stream-ref stream index))))
  631.  
  632. ;;;; Stack Frame Types
  633.  
  634. (define-structure (stack-frame-type
  635.            (constructor make-stack-frame-type
  636.                 (code subproblem? history-subproblem?
  637.                       length parser))
  638.            (conc-name stack-frame-type/))
  639.   (code #f read-only #t)
  640.   (subproblem? #f read-only #t)
  641.   (history-subproblem? #f read-only #t)
  642.   (properties (make-1d-table) read-only #t)
  643.   (length #f read-only #t)
  644.   (parser #f read-only #t))
  645.  
  646. (define allow-extended?-tag "stack-frame-type/allow-extended?")
  647.  
  648. (define (microcode-return/code->type code)
  649.   (if (not (< code (vector-length stack-frame-types)))
  650.       (error "return-code too large" code))
  651.   (vector-ref stack-frame-types code))
  652.  
  653. (define (microcode-return/name->type name)
  654.   (microcode-return/code->type (microcode-return name)))
  655.  
  656. (define (return-address->stack-frame-type return-address allow-extended?)
  657.   allow-extended?            ; ignored
  658.   (let ((allow-extended? #t))
  659.     (cond ((interpreter-return-address? return-address)
  660.        (let ((code (return-address/code return-address)))
  661.          (let ((type (microcode-return/code->type code)))
  662.            (if (not type)
  663.            (error "return-code has no type" code))
  664.            type)))
  665.       ((compiled-return-address? return-address)
  666.        (cond ((compiled-continuation/return-to-interpreter? return-address)
  667.           stack-frame-type/return-to-interpreter)
  668.          ((compiled-continuation/reflect-to-interface? return-address)
  669.           stack-frame-type/special-compiled)
  670.          (else stack-frame-type/compiled-return-address)))
  671.       ((and allow-extended? (compiled-procedure? return-address))
  672.        stack-frame-type/interrupt-compiled-procedure)
  673.       ((and allow-extended? (compiled-expression? return-address))
  674.        stack-frame-type/interrupt-compiled-expression)
  675.       (else (error "illegal return address" return-address)))))
  676.  
  677. (define (initialize-package!)
  678.   (set! return-address/join-stacklets
  679.     (make-return-address (microcode-return 'JOIN-STACKLETS)))
  680.   (set! return-address/reenter-compiled-code
  681.     (make-return-address (microcode-return 'REENTER-COMPILED-CODE)))
  682.   (set! stack-frame-types (make-stack-frame-types))
  683.   (set! stack-frame-type/hardware-trap
  684.     (microcode-return/name->type 'HARDWARE-TRAP))
  685.   (set! stack-frame-type/stack-marker
  686.     (microcode-return/name->type 'STACK-MARKER))
  687.   (set! stack-frame-type/compiled-return-address
  688.     (make-stack-frame-type #f #t #f
  689.                    length/compiled-return-address
  690.                    parser/standard-compiled))
  691.   (set! stack-frame-type/return-to-interpreter
  692.     (make-stack-frame-type #f #f #t 1 parser/standard))
  693.   (set! stack-frame-type/special-compiled
  694.     (make-stack-frame-type #f #t #f
  695.                    length/special-compiled
  696.                    parser/special-compiled))
  697.   (set! stack-frame-type/interrupt-compiled-procedure
  698.     (make-stack-frame-type #f #t #f
  699.                    length/interrupt-compiled-procedure
  700.                    parser/standard))
  701.   (set! stack-frame-type/interrupt-compiled-expression
  702.     (make-stack-frame-type #f #t #f 1 parser/standard))
  703.   (set! word-size
  704.     (let ((initial (system-vector-length (make-bit-string 1 #f))))
  705.       (let loop ((size 2))
  706.         (if (= (system-vector-length (make-bit-string size #f)) initial)
  707.         (loop (+ size 1))
  708.         (- size 1)))))
  709.   (set! continuation-return-address #f)
  710.   unspecific)
  711.  
  712. (define stack-frame-types)
  713. (define stack-frame-type/compiled-return-address)
  714. (define stack-frame-type/return-to-interpreter)
  715. (define stack-frame-type/special-compiled)
  716. (define stack-frame-type/hardware-trap)
  717. (define stack-frame-type/stack-marker)
  718. (define stack-frame-type/interrupt-compiled-procedure)
  719. (define stack-frame-type/interrupt-compiled-expression)
  720.  
  721. (define (make-stack-frame-types)
  722.   (let ((types (make-vector (microcode-return/code-limit) #f)))
  723.  
  724.     (define (stack-frame-type name subproblem?
  725.                   history-subproblem?
  726.                   length parser)
  727.       (let ((code (microcode-return name)))
  728.     (let ((type (make-stack-frame-type code subproblem?
  729.                        history-subproblem?
  730.                        length parser)))
  731.       (vector-set! types code type)
  732.       type)))
  733.  
  734.     (define (standard-frame name length #!optional parser)
  735.       (stack-frame-type name
  736.             #f
  737.             #f
  738.             length
  739.             (if (default-object? parser)
  740.                 parser/standard
  741.                 parser)))
  742.  
  743.     (define (standard-subproblem name length)
  744.       (stack-frame-type name
  745.             #t
  746.             #t
  747.             length
  748.             parser/standard))
  749.  
  750.     (define (non-history-subproblem name length #!optional parser)
  751.       (stack-frame-type name
  752.             #t
  753.             #f
  754.             length
  755.             (if (default-object? parser)
  756.                 parser/standard
  757.                 parser)))
  758.  
  759.     (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
  760.     (standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
  761.     (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history)
  762.     (standard-frame 'STACK-MARKER 3 parser/stack-marker)
  763.  
  764.     (standard-frame 'NON-EXISTENT-CONTINUATION 2)
  765.     (standard-frame 'HALT 2)
  766.     (standard-frame 'JOIN-STACKLETS 2)
  767.     (standard-frame 'POP-RETURN-ERROR 2)
  768.     (standard-frame 'RESTORE-VALUE 2)
  769.  
  770.     (standard-subproblem 'IN-PACKAGE-CONTINUE 2)
  771.     (standard-subproblem 'ACCESS-CONTINUE 2)
  772.     (standard-subproblem 'PRIMITIVE-COMBINATION-1-APPLY 2)
  773.     (standard-subproblem 'FORCE-SNAP-THUNK 2)
  774.     (standard-subproblem 'GC-CHECK 2)
  775.     (standard-subproblem 'ASSIGNMENT-CONTINUE 3)
  776.     (standard-subproblem 'DEFINITION-CONTINUE 3)
  777.     (standard-subproblem 'SEQUENCE-2-SECOND 3)
  778.     (standard-subproblem 'SEQUENCE-3-SECOND 3)
  779.     (standard-subproblem 'SEQUENCE-3-THIRD 3)
  780.     (standard-subproblem 'CONDITIONAL-DECIDE 3)
  781.     (standard-subproblem 'DISJUNCTION-DECIDE 3)
  782.     (standard-subproblem 'COMBINATION-1-PROCEDURE 3)
  783.     (standard-subproblem 'COMBINATION-2-FIRST-OPERAND 3)
  784.     (standard-subproblem 'EVAL-ERROR 3)
  785.     (standard-subproblem 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND 3)
  786.     (standard-subproblem 'PRIMITIVE-COMBINATION-2-APPLY 3)
  787.     (standard-subproblem 'PRIMITIVE-COMBINATION-3-SECOND-OPERAND 3)
  788.     (standard-subproblem 'COMBINATION-2-PROCEDURE 4)
  789.     (standard-subproblem 'REPEAT-DISPATCH 4)
  790.     (standard-subproblem 'PRIMITIVE-COMBINATION-3-FIRST-OPERAND 4)
  791.     (standard-subproblem 'PRIMITIVE-COMBINATION-3-APPLY 4)
  792.     (standard-subproblem 'MOVE-TO-ADJACENT-POINT 6)
  793.     (standard-subproblem 'COMBINATION-SAVE-VALUE length/combination-save-value)
  794.  
  795.     (let ((length (length/application-frame 2 0)))
  796.       (standard-subproblem 'COMBINATION-APPLY length)
  797.       (non-history-subproblem 'INTERNAL-APPLY length parser/apply)
  798.       (non-history-subproblem 'INTERNAL-APPLY-VAL length parser/apply))
  799.  
  800.     (let ((compiler-frame
  801.        (lambda (name length)
  802.          (stack-frame-type name #f #t length parser/standard)))
  803.       (compiler-subproblem
  804.        (lambda (name length)
  805.          (stack-frame-type name #t #t length parser/standard))))
  806.  
  807.       (let ((length (length/application-frame 4 0)))
  808.     (compiler-subproblem 'COMPILER-LOOKUP-APPLY-TRAP-RESTART length)
  809.     (compiler-subproblem 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART length))
  810.  
  811.       (let ((type (compiler-frame 'COMPILER-INTERRUPT-RESTART 3)))
  812.     (1d-table/put! (stack-frame-type/properties type)
  813.                allow-extended?-tag
  814.                #t))
  815.  
  816.       (compiler-frame 'COMPILER-LINK-CACHES-RESTART 8)
  817.       (compiler-frame 'REENTER-COMPILED-CODE 2)
  818.  
  819.       (compiler-subproblem 'COMPILER-ACCESS-RESTART 4)
  820.       (compiler-subproblem 'COMPILER-ASSIGNMENT-RESTART 5)
  821.       (compiler-subproblem 'COMPILER-ASSIGNMENT-TRAP-RESTART 5)
  822.       (compiler-subproblem 'COMPILER-DEFINITION-RESTART 5)
  823.       (compiler-subproblem 'COMPILER-LOOKUP-APPLY-RESTART
  824.                (length/application-frame 4 1))
  825.       (compiler-subproblem 'COMPILER-REFERENCE-RESTART 4)
  826.       (compiler-subproblem 'COMPILER-REFERENCE-TRAP-RESTART 4)
  827.       (compiler-subproblem 'COMPILER-SAFE-REFERENCE-RESTART 4)
  828.       (compiler-subproblem 'COMPILER-SAFE-REFERENCE-TRAP-RESTART 4)
  829.       (compiler-subproblem 'COMPILER-UNASSIGNED?-RESTART 4)
  830.       (compiler-subproblem 'COMPILER-UNASSIGNED?-TRAP-RESTART 4)
  831.       (compiler-subproblem 'COMPILER-UNBOUND?-RESTART 4)
  832.  
  833.       (compiler-subproblem 'COMPILER-ERROR-RESTART 3))
  834.  
  835.     (non-history-subproblem 'HARDWARE-TRAP length/hardware-trap)
  836.     types))
  837.  
  838. ;;;; Hardware trap parsing
  839.  
  840. (define-integrable hardware-trap/frame-size 9)
  841.  
  842. (define-integrable hardware-trap/signal-index 1)
  843. (define-integrable hardware-trap/signal-name-index 2)
  844. (define-integrable hardware-trap/code-index 3)
  845. (define-integrable hardware-trap/stack-index 4)
  846. (define-integrable hardware-trap/state-index 5)
  847. (define-integrable hardware-trap/pc-info1-index 6)
  848. (define-integrable hardware-trap/pc-info2-index 7)
  849. (define-integrable hardware-trap/extra-info-index 8)
  850.  
  851. (define (length/hardware-trap stream offset)
  852.   (let ((state (element-stream/ref stream hardware-trap/state-index))
  853.     (stack-recovered?
  854.      (element-stream/ref stream hardware-trap/stack-index)))
  855.     (if (not stack-recovered?)
  856.     hardware-trap/frame-size
  857.     (let ((after-header (stream-tail stream hardware-trap/frame-size)))
  858.       (case state
  859.         ((1)
  860.          ;; primitive
  861.          (let* ((primitive
  862.              (element-stream/ref stream hardware-trap/pc-info1-index))
  863.             (arity (primitive-procedure-arity primitive))
  864.             (nargs
  865.              (if (negative? arity)
  866.              (element-stream/ref stream
  867.                          hardware-trap/pc-info2-index)
  868.              arity)))
  869.            (if (return-address? (element-stream/ref after-header nargs))
  870.            (+ hardware-trap/frame-size nargs)
  871.            (- (heuristic (stream-tail after-header nargs)
  872.                  (+ hardware-trap/frame-size nargs offset))
  873.               offset))))
  874.         ((0 2 3 4 5)
  875.          ;; unknown, cc, probably cc, builtin, or utility
  876.          (- (heuristic after-header (+ hardware-trap/frame-size offset))
  877.         offset))
  878.         (else
  879.          (error "length/hardware-trap: Unknown state" state)))))))
  880.  
  881. (define (heuristic stream offset)
  882.   (if (or (stream-null? stream)
  883.       (and (return-address? (element-stream/head stream))
  884.            (verify 2 stream offset)))
  885.       offset
  886.       (heuristic (stream-cdr stream) (1+ offset))))
  887.  
  888. (define (hardware-trap-frame? frame)
  889.   (and (stack-frame? frame)
  890.        (eq? (stack-frame/type frame)
  891.         stack-frame-type/hardware-trap)))
  892.  
  893. (define (hardware-trap-frame/code frame)
  894.   (guarantee-hardware-trap-frame frame)
  895.   (let ((code (stack-frame/ref frame hardware-trap/code-index)))
  896.     (cond ((pair? code) (cdr code))
  897.       ((string? code) code)
  898.       (else #f))))
  899.  
  900. (define (guarantee-hardware-trap-frame frame)
  901.   (if (not (hardware-trap-frame? frame))
  902.       (error "guarantee-hardware-trap-frame: invalid" frame)))
  903.  
  904. (define (hardware-trap-frame/print-registers frame)
  905.   (guarantee-hardware-trap-frame frame)
  906.   (let ((block (stack-frame/ref frame hardware-trap/extra-info-index)))
  907.     (if block
  908.     (let ((nregs (- (system-vector-length block) 2)))
  909.       (print-register block 0 "pc")
  910.       (print-register block 1 "sp")
  911.       (let loop ((i 0))
  912.         (if (< i nregs)
  913.         (begin
  914.           (print-register block
  915.                   (+ 2 i)
  916.                   (string-append "register "
  917.                          (number->string i)))
  918.           (loop (1+ i)))))))))
  919.  
  920. (define (print-register block index name)
  921.   (let ((value
  922.      (let ((bit-string (bit-string-allocate word-size)))
  923.        (read-bits! block (* word-size (1+ index)) bit-string)
  924.        (bit-string->unsigned-integer bit-string))))
  925.     (newline)
  926.     (write-string "  ")
  927.     (write-string name)
  928.     (write-string " = ")
  929.     (write-string (number->string value 16))))
  930.  
  931. (define word-size)
  932.  
  933. (define (hardware-trap-frame/print-stack frame)
  934.   (guarantee-hardware-trap-frame frame)
  935.   (let ((elements
  936.      (let ((elements (stack-frame/elements frame)))
  937.        (subvector->list elements
  938.                 hardware-trap/frame-size
  939.                 (vector-length elements)))))
  940.     (if (null? elements)
  941.     (begin
  942.       (newline)
  943.       (write-string ";; Empty stack"))
  944.     (begin
  945.       (newline)
  946.       (write-string ";; Bottom of the stack")
  947.       (for-each (lambda (element)
  948.               (newline)
  949.               (write-string "  ")
  950.               (write element))
  951.             (reverse elements))
  952.       (newline)
  953.       (write-string ";; Top of the stack")))))
  954.  
  955. (define (write-hex value)
  956.   (if (< value #x10)
  957.       (write value)
  958.       (begin
  959.     (write-string "#x")
  960.     (write-string (number->string value #x10)))))
  961.  
  962. (define (hardware-trap-frame/describe frame long?)
  963.   (guarantee-hardware-trap-frame frame)
  964.   (let ((name (stack-frame/ref frame hardware-trap/signal-name-index))
  965.     (state (stack-frame/ref frame hardware-trap/state-index)))
  966.     (if (not name)
  967.     (write-string "User microcode reset")
  968.     (let ((code (stack-frame/ref frame hardware-trap/code-index)))
  969.       (write-string "Hardware trap ")
  970.       (write-string name)
  971.       (write-string " (")
  972.       (if (and (pair? code) (cdr code))
  973.           (write-string (cdr code))
  974.           (begin
  975.         (write-string "code = ")
  976.         (write-hex (if (pair? code)
  977.                    (car code)
  978.                    code))))
  979.       (write-string ")")))
  980.     (if long?
  981.     (case state
  982.       ((0)                ; unknown
  983.        (write-string " at an unknown location."))
  984.       ((1)                ; primitive
  985.        (write-string " within ")
  986.        (write (stack-frame/ref frame hardware-trap/pc-info1-index)))
  987.       ((2)                ; compiled code
  988.        (write-string " at offset ")
  989.        (write-hex (stack-frame/ref frame hardware-trap/pc-info2-index))
  990.        (newline)
  991.        (write-string "within ")
  992.        (let ((block (stack-frame/ref frame hardware-trap/pc-info1-index)))
  993.          (write block)
  994.          (let loop ((info (compiled-code-block/debugging-info block)))
  995.            (cond ((null? info)
  996.               #f)
  997.              ((string? info)
  998.               (begin
  999.             (write-string " (")
  1000.             (write-string info)
  1001.             (write-string ")")))
  1002.              ((not (pair? info))
  1003.               #f)
  1004.              ((string? (car info))
  1005.               (loop (car info)))
  1006.              (else
  1007.               (loop (cdr info)))))))
  1008.       ((3)                ; probably compiled-code
  1009.        (write-string " at an unknown compiled-code location."))
  1010.       ((4)                ; builtin (i.e. hook)
  1011.        (let* ((index (stack-frame/ref frame hardware-trap/pc-info1-index))
  1012.           (name ((ucode-primitive builtin-index->name 1) index)))
  1013.          (if name
  1014.          (begin
  1015.            (write-string " in assembly-language utility ")
  1016.            (write-string name))
  1017.          (begin
  1018.            (write-string " in unknown assembly-language utility ")
  1019.            (write-hex index)))))
  1020.       ((5)                ; utility
  1021.        (let* ((index (stack-frame/ref frame hardware-trap/pc-info1-index))
  1022.           (name ((ucode-primitive utility-index->name 1) index)))
  1023.          (if name
  1024.          (begin
  1025.            (write-string " in compiled-code utility ")
  1026.            (write-string name))
  1027.          (begin
  1028.            (write-string " in unknown compiled-code utility ")
  1029.            (write-hex index)))))
  1030.       (else
  1031.        (error "hardware-trap/describe: Unknown state" state))))))