← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/runtime/conpar.scm

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2005-09-12 21:36:33 UTC
  • mfrom: (1.1.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050912213633-shybia1ie66exjvl
Tags: 7.7.90+20050912-1
http://bugs.debian.org/323739
* Acknowledge NMU (thanks Matej!).  (closes: Bug#323739)
* New upstream snapshot.
* Bump standards version to 3.6.2 (no changes).
* Drop texi2html from build dependencies; no longer used.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/runtime/conpar.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: conpar.scm,v 14.42 2003/07/22 02:12:52 cph Exp $
 
3
$Id: conpar.scm,v 14.49 2005/08/20 01:57:26 cph Exp $
4
4
 
5
 
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
5
Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 
6
Copyright 1994,1999,2001,2003,2004,2005 Massachusetts Institute of Technology
6
7
 
7
8
This file is part of MIT/GNU Scheme.
8
9
 
64
65
        (history-reductions history))))
65
66
 
66
67
(define undefined-history
67
 
  "no history")
 
68
  (list 'UNDEFINED-HISTORY))
68
69
 
69
70
(define (stack-frame/next stack-frame)
70
71
  (let ((next (stack-frame/%next stack-frame)))
90
91
(define (stack-frame/ref stack-frame index)
91
92
  (let ((elements (stack-frame/elements stack-frame)))
92
93
    (let ((length (vector-length elements)))
93
 
      (if (< index length)
94
 
          (map-reference-trap (lambda () (vector-ref elements index)))
95
 
          (stack-frame/ref (stack-frame/next stack-frame) (- index length))))))
 
94
      (if (fix:< index length)
 
95
          (vector-ref elements index)
 
96
          (stack-frame/ref (stack-frame/next stack-frame)
 
97
                           (fix:- index length))))))
96
98
 
97
99
(define-integrable (stack-frame/return-address stack-frame)
98
100
  (stack-frame/ref stack-frame 0))
115
117
      ((frame frame)
116
118
       (offset (stack-address->index address (stack-frame/offset frame))))
117
119
    (let ((length (stack-frame/length frame)))
118
 
      (if (< offset length)
 
120
      (if (fix:< offset length)
119
121
          (values frame offset)
120
 
          (loop (stack-frame/next frame) (- offset length))))))
 
122
          (loop (stack-frame/next frame) (fix:- offset length))))))
121
123
 
122
124
(define (stack-frame/skip-non-subproblems stack-frame)
123
125
  (let ((type (stack-frame/type stack-frame)))
186
188
             (history-transform (control-point/history control-point))))
187
189
        (if (and (stream-pair? element-stream)
188
190
                 (eq? return-address/reenter-compiled-code
189
 
                      (element-stream/head element-stream)))
 
191
                      (stream-car element-stream)))
190
192
            history
191
193
            (history-superproblem history)))
192
194
      (control-point/previous-history-offset control-point)
197
199
      type))))
198
200
 
199
201
(define (parse-one-frame state)
200
 
  (define (handle-ordinary stream)
201
 
    (let ((type
202
 
           (return-address->stack-frame-type
203
 
            (element-stream/head stream)
204
 
            (let ((type (parser-state/previous-type state)))
205
 
              (and type
206
 
                   (1d-table/get (stack-frame-type/properties type)
207
 
                                 allow-extended?-tag
208
 
                                 #f))))))
209
 
      (let ((length
210
 
             (let ((length (stack-frame-type/length type)))
211
 
               (if (exact-nonnegative-integer? length)
212
 
                   length
213
 
                   (length stream (parser-state/n-elements state))))))
214
 
        ((stack-frame-type/parser type)
215
 
         type
216
 
         (list->vector (stream-head stream length))
217
 
         (make-intermediate-state state length (stream-tail stream length))))))
218
 
 
219
 
  (let ((the-stream (parser-state/element-stream state)))
 
202
  (let ((handle-ordinary
 
203
         (lambda (stream)
 
204
           (let ((type
 
205
                  (return-address->stack-frame-type
 
206
                   (stream-car stream)
 
207
                   (let ((type (parser-state/previous-type state)))
 
208
                     (and type
 
209
                          (1d-table/get (stack-frame-type/properties type)
 
210
                                        allow-extended?-tag
 
211
                                        #f))))))
 
212
             (let ((length
 
213
                    (let ((length (stack-frame-type/length type)))
 
214
                      (if (exact-nonnegative-integer? length)
 
215
                          length
 
216
                          (length stream (parser-state/n-elements state))))))
 
217
               ((stack-frame-type/parser type)
 
218
                type
 
219
                (list->vector (stream-head stream length))
 
220
                (make-intermediate-state state
 
221
                                         length
 
222
                                         (stream-tail stream length)))))))
 
223
        (the-stream (parser-state/element-stream state)))
220
224
    (if (stream-pair? the-stream)
221
225
        (handle-ordinary the-stream)
222
226
        (let ((control-point (parser-state/next-control-point state)))
223
227
          (and control-point
224
 
               (if (not (zero? (parser-state/n-elements state)))
 
228
               (if (fix:> (parser-state/n-elements state) 0)
225
229
                   ;; Construct invisible join-stacklets frame.
226
230
                   (handle-ordinary
227
231
                    (stream return-address/join-stacklets control-point))
231
235
                    (parser-state/block-thread-events? state)
232
236
                    (parser-state/previous-type state))))))))
233
237
 
234
 
;;; `make-intermediate-state' is used to construct an intermediate
 
238
;;; MAKE-INTERMEDIATE-STATE is used to construct an intermediate
235
239
;;; parser state that is passed to the frame parser.  This
236
 
;;; intermediate state is identical to `state' except that it shows
237
 
;;; `length' items having been removed from the stream.
 
240
;;; intermediate state is identical to STATE except that it shows
 
241
;;; LENGTH items having been removed from the stream.
238
242
 
239
243
(define (make-intermediate-state state length stream)
240
244
  (let ((previous-history-control-point
241
245
         (parser-state/previous-history-control-point state))
242
246
        (new-length
243
 
         (- (parser-state/n-elements state) length)))
 
247
         (fix:- (parser-state/n-elements state) length)))
244
248
    (make-parser-state
245
249
     (parser-state/dynamic-state state)
246
250
     (parser-state/block-thread-events? state)
248
252
     (parser-state/history state)
249
253
     (let ((previous (parser-state/previous-history-offset state)))
250
254
       (if (or previous-history-control-point
251
 
               (>= new-length previous))
 
255
               (fix:>= new-length previous))
252
256
           previous
253
257
           0))
254
258
     previous-history-control-point
258
262
     (parser-state/previous-type state))))
259
263
 
260
264
;;; After each frame parser is done, it either tail recurses into the
261
 
;;; parsing loop, or it calls `parser/standard' to produces a new
262
 
;;; output frame.  The argument `state' is usually what was passed to
 
265
;;; parsing loop, or it calls PARSE/STANDARD-NEXT to produces a new
 
266
;;; output frame.  The argument STATE is usually what was passed to
263
267
;;; the frame parser (i.e. the state that was returned by the previous
264
 
;;; call to `make-intermediate-state').  However, several of the
265
 
;;; parsers change the values of some of the components of `state'
266
 
;;; before calling `parser/standard' -- for example,
267
 
;;; RESTORE-INTERRUPT-MASK changes the `interrupt-mask' component.
 
268
;;; call to MAKE-INTERMEDIATE-STATE).  However, several of the parsers
 
269
;;; change the values of some of the components of STATE before
 
270
;;; calling PARSE/STANDARD-NEXT -- for example, RESTORE-INTERRUPT-MASK
 
271
;;; changes the INTERRUPT-MASK component.
268
272
 
269
273
(define (parse/standard-next type elements state history? force-pop?)
270
274
  (let ((n-elements (parser-state/n-elements state))
285
289
         undefined-history)
286
290
     previous-history-offset
287
291
     previous-history-control-point
288
 
     (+ (vector-length elements) n-elements)
 
292
     (fix:+ (vector-length elements) n-elements)
289
293
     (parser-state/previous-type state)
290
294
     (make-parser-state (parser-state/dynamic-state state)
291
295
                        (parser-state/block-thread-events? state)
311
315
   type elements state
312
316
   (let ((stream (parser-state/element-stream state)))
313
317
     (and (stream-pair? stream)
314
 
          (eq? (return-address->stack-frame-type (element-stream/head stream)
315
 
                                                 #t)
 
318
          (eq? (return-address->stack-frame-type (stream-car stream) #t)
316
319
               stack-frame-type/return-to-interpreter)))
317
320
   #f))
318
321
 
321
324
         (not (let ((stream (parser-state/element-stream state)))
322
325
                (and (stream-pair? stream)
323
326
                     (eq? return-address/reenter-compiled-code
324
 
                          (element-stream/head stream)))))))
 
327
                          (stream-car stream)))))))
325
328
    (parse/standard-next type elements state valid-history? valid-history?)))
326
329
 
327
330
(define (parser/restore-interrupt-mask type elements state)
381
384
               (fix:= code code/continue-linking))
382
385
           (parse/standard-next type elements state #f #f))
383
386
          (else
384
 
           (error "Unknown special compiled frame" code)))))
 
387
           (error "Unknown special compiled frame code:" code)))))
385
388
 
386
389
(define (parser/stack-marker type elements state)
387
390
  (call-with-values
462
465
;;;; Unparser
463
466
 
464
467
(define (stack-frame->continuation stack-frame)
465
 
  (make-continuation 'REENTRANT
466
 
                     (stack-frame->control-point stack-frame)
 
468
  (make-continuation (stack-frame->control-point stack-frame)
467
469
                     (stack-frame/dynamic-state stack-frame)
468
470
                     #f))
469
471
 
471
473
  (with-values (lambda () (unparse/stack-frame stack-frame))
472
474
    (lambda (element-stream next-control-point)
473
475
      (make-control-point
474
 
       #f
475
 
       0
476
476
       (stack-frame/interrupt-mask stack-frame)
477
477
       (let ((history (stack-frame/history stack-frame)))
478
478
         (if (eq? history undefined-history)
505
505
           (let ((elements (stack-frame/elements stack-frame)))
506
506
             (let ((length (vector-length elements)))
507
507
               (let loop ((index 0))
508
 
                 (if (< index length)
 
508
                 (if (fix:< index length)
509
509
                     (cons-stream (vector-ref elements index)
510
 
                                  (loop (1+ index)))
 
510
                                  (loop (fix:+ index 1)))
511
511
                     element-stream))))
512
512
           next-control-point)))))
513
513
 
518
518
 
519
519
(define (length/combination-save-value stream offset)
520
520
  offset
521
 
  (+ 3 (system-vector-length (element-stream/ref stream 1))))
 
521
  (fix:+ 3 (system-vector-length (stream-ref stream 1))))
522
522
 
523
523
(define ((length/application-frame index missing) stream offset)
524
524
  offset
525
 
  (+ index 1 (- (object-datum (element-stream/ref stream index)) missing)))
 
525
  (fix:+ (fix:+ index 1)
 
526
         (fix:- (object-datum (stream-ref stream index)) missing)))
526
527
 
527
528
(define (length/compiled-return-address stream offset)
528
 
  (let ((entry (element-stream/head stream)))
 
529
  (let ((entry (stream-car stream)))
529
530
    (let ((frame-size (compiled-continuation/next-continuation-offset entry)))
530
531
      (if frame-size
531
 
          (1+ frame-size)
532
 
          (stack-address->index (element-stream/ref stream 1) offset)))))
 
532
          (fix:+ frame-size 1)
 
533
          (stack-address->index
 
534
           ;; Search for the dynamic link.  This heuristic compensates
 
535
           ;; for the compiler omitting its location in the object
 
536
           ;; code.
 
537
           (let loop ((s (stream-cdr stream)))
 
538
             (if (not (stream-pair? s))
 
539
                 (error "Unable to find dynamic link:" stream))
 
540
             (let ((item (stream-car s)))
 
541
               (if (stack-address? item)
 
542
                   item
 
543
                   (loop (stream-cdr s)))))
 
544
           offset)))))
533
545
 
534
546
(define (length/special-compiled stream offset)
535
547
  ;; return address is reflect-to-interface
536
548
  offset
537
 
  (let ((code (element-stream/ref stream 1)))
538
 
    (define (default)
539
 
      (error "length/special-compiled: Unknown code" code))
540
 
 
 
549
  (let* ((code (stream-ref stream 1))
 
550
         (lose
 
551
          (lambda () (error "Unknown special compiled frame code:" code))))
541
552
    (cond ((not (fix:fixnum? code))
542
 
           (default))
 
553
           (lose))
543
554
          ((fix:= code code/special-compiled/internal-apply)
544
555
           ;; Very infrequent!
545
 
           (fix:+ 3 (object-datum (element-stream/ref stream 2))))
 
556
           (fix:+ 3 (object-datum (stream-ref stream 2))))
546
557
          ((fix:= code code/special-compiled/restore-interrupt-mask)
547
558
           3)
548
559
          ((fix:= code code/special-compiled/stack-marker)
550
561
          ((fix:= code code/special-compiled/compiled-code-bkpt)
551
562
           ;; Very infrequent!
552
563
           (let ((fsize
553
 
                  (compiled-code-address/frame-size
554
 
                   (element-stream/ref stream 2))))
 
564
                  (compiled-code-address/frame-size (stream-ref stream 2))))
555
565
             (if (not fsize)
556
566
                 5
557
567
                 (fix:+ 5 fsize))))
558
568
          ((fix:= code code/interrupt-restart)
559
 
           (let ((homes-saved (object-datum (element-stream/ref stream 2)))
560
 
                 (regs-saved (object-datum (element-stream/ref stream 3))))
 
569
           (let ((homes-saved (object-datum (stream-ref stream 2)))
 
570
                 (regs-saved (object-datum (stream-ref stream 3))))
561
571
             ;; The first reg saved is _always_ the continuation,
562
572
             ;; part of the next frame.
563
573
             (fix:- (fix:+
567
577
                     (fix:+ homes-saved regs-saved))
568
578
                    1)))
569
579
          ((fix:= code code/restore-regs)
570
 
           (fix:+ 3 (object-datum (element-stream/ref stream 2))))
 
580
           (fix:+ 3 (object-datum (stream-ref stream 2))))
571
581
          ((fix:= code code/apply-compiled)
572
582
           ;; Stream[2] is code entry point, [3] is frame size
573
 
           (+ 3 (object-datum (element-stream/ref stream 3))))
 
583
           (fix:+ 3 (object-datum (stream-ref stream 3))))
574
584
          ((fix:= code code/continue-linking)
575
585
           ;; return code, reflect code, entry size, original count,
576
586
           ;; block, environment, offset, last header offset,sections,
577
587
           ;; return address
578
588
           (fix:- 10 1))
579
589
          (else
580
 
           (default)))))
 
590
           (lose)))))
581
591
 
582
592
(define (length/interrupt-compiled-procedure stream offset)
583
593
  offset                                ; ignored
584
 
  (1+ (compiled-procedure-frame-size (element-stream/head stream))))
 
594
  (fix:+ (compiled-procedure-frame-size (stream-car stream)) 1))
585
595
 
586
596
(define (compiled-code-address/frame-size cc-address)
587
 
  (cond ((not (compiled-code-address? cc-address))
588
 
         (error "compiled-code-address/frame-size: Unexpected object"
589
 
                cc-address))
590
 
        ((compiled-return-address? cc-address)
591
 
         (let ((offset
592
 
                (compiled-continuation/next-continuation-offset cc-address)))
593
 
           (and offset
594
 
                (fix:+ offset 1))))
595
 
        ((compiled-procedure? cc-address)
596
 
         (fix:+ (compiled-procedure-frame-size cc-address) 1))
597
 
        (else
598
 
         (error "compiled-code-address/frame-size: Unexpected object"
599
 
                cc-address))))
 
597
  (let ((lose (lambda () (error "Unexpected object:" cc-address))))
 
598
    (cond ((not (compiled-code-address? cc-address))
 
599
           (lose))
 
600
          ((compiled-return-address? cc-address)
 
601
           (let ((offset
 
602
                  (compiled-continuation/next-continuation-offset cc-address)))
 
603
             (and offset
 
604
                  (fix:+ offset 1))))
 
605
          ((compiled-procedure? cc-address)
 
606
           (fix:+ (compiled-procedure-frame-size cc-address) 1))
 
607
          (else
 
608
           (lose)))))
600
609
 
601
610
(define (verify paranoia-index stream offset)
602
 
  (or (zero? paranoia-index)
603
 
      (stream-null? stream)
604
 
      (let* ((type
605
 
              (return-address->stack-frame-type (element-stream/head stream)
606
 
                                                #f))
 
611
  (if (or (= paranoia-index 0) (stream-null? stream))
 
612
      #t
 
613
      (let* ((type (return-address->stack-frame-type (stream-car stream) #f))
607
614
             (length
608
615
              (let ((length (stack-frame-type/length type)))
609
616
                (if (exact-nonnegative-integer? length)
611
618
                    (length stream offset))))
612
619
             (ltail (stream-tail* stream length)))
613
620
        (and ltail
614
 
             (return-address? (element-stream/head ltail))
615
 
             (verify (-1+ paranoia-index)
 
621
             (return-address? (stream-car ltail))
 
622
             (verify (- paranoia-index 1)
616
623
                     ltail
617
 
                     (+ offset length))))))
 
624
                     (fix:+ offset length))))))
618
625
 
619
626
(define (stream-tail* stream n)
620
 
  (cond ((or (zero? n) (stream-null? stream))
621
 
         stream)
622
 
        ((stream-pair? stream)
623
 
         (stream-tail* (stream-cdr stream) (-1+ n)))
624
 
        (else
625
 
         (error "stream-tail*: not a proper stream" stream))))
626
 
 
627
 
(define (element-stream/head stream)
628
 
  (if (not (stream-pair? stream)) (error "not a stream-pair" stream))
629
 
  (map-reference-trap (lambda () (stream-car stream))))
630
 
 
631
 
(define-integrable (element-stream/ref stream index)
632
 
  (map-reference-trap (lambda () (stream-ref stream index))))
 
627
  (if (or (fix:= n 0) (stream-null? stream))
 
628
      stream
 
629
      (begin
 
630
        (if (not (stream-pair? stream))
 
631
            (error:wrong-type-argument stream "stream" 'STREAM-TAIL*))
 
632
        (stream-tail* (stream-cdr stream) (fix:- n 1)))))
633
633
 
634
634
;;;; Stack Frame Types
635
635
 
636
636
(define-structure (stack-frame-type
637
637
                   (constructor make-stack-frame-type
638
 
                                (code subproblem? history-subproblem?
639
 
                                      length parser))
 
638
                                (code subproblem? history-subproblem? length
 
639
                                      parser))
640
640
                   (conc-name stack-frame-type/))
641
641
  (code #f read-only #t)
642
642
  (subproblem? #f read-only #t)
643
643
  (history-subproblem? #f read-only #t)
644
 
  (properties (make-1d-table) read-only #t)
645
644
  (length #f read-only #t)
646
 
  (parser #f read-only #t))
 
645
  (parser #f read-only #t)
 
646
  (properties (make-1d-table) read-only #t))
647
647
 
648
 
(define allow-extended?-tag "stack-frame-type/allow-extended?")
 
648
(define allow-extended?-tag
 
649
  (list 'ALLOW-EXTENDED?))
649
650
 
650
651
(define (microcode-return/code->type code)
651
 
  (if (not (< code (vector-length stack-frame-types)))
652
 
      (error "return-code too large" code))
 
652
  (if (not (fix:< code (vector-length stack-frame-types)))
 
653
      (error:bad-range-argument code 'MICROCODE-RETURN/CODE->TYPE))
653
654
  (vector-ref stack-frame-types code))
654
655
 
655
656
(define (microcode-return/name->type name)
657
658
 
658
659
(define (return-address->stack-frame-type return-address allow-extended?)
659
660
  allow-extended?                       ; ignored
660
 
  (let ((allow-extended? #t))
661
 
    (cond ((interpreter-return-address? return-address)
662
 
           (let ((code (return-address/code return-address)))
663
 
             (let ((type (microcode-return/code->type code)))
664
 
               (if (not type)
665
 
                   (error "return-code has no type" code))
666
 
               type)))
667
 
          ((compiled-return-address? return-address)
668
 
           (cond ((compiled-continuation/return-to-interpreter? return-address)
669
 
                  stack-frame-type/return-to-interpreter)
670
 
                 ((compiled-continuation/reflect-to-interface? return-address)
671
 
                  stack-frame-type/special-compiled)
672
 
                 (else stack-frame-type/compiled-return-address)))
673
 
          ((and allow-extended? (compiled-procedure? return-address))
674
 
           stack-frame-type/interrupt-compiled-procedure)
675
 
          ((and allow-extended? (compiled-expression? return-address))
676
 
           stack-frame-type/interrupt-compiled-expression)
677
 
          (else (error "illegal return address" return-address)))))
 
661
  (cond ((interpreter-return-address? return-address)
 
662
         (let ((code (return-address/code return-address)))
 
663
           (let ((type (microcode-return/code->type code)))
 
664
             (if (not type)
 
665
                 (error "Return code has no type:" code))
 
666
             type)))
 
667
        ((compiled-return-address? return-address)
 
668
         (cond ((compiled-continuation/return-to-interpreter? return-address)
 
669
                stack-frame-type/return-to-interpreter)
 
670
               ((compiled-continuation/reflect-to-interface? return-address)
 
671
                stack-frame-type/special-compiled)
 
672
               (else stack-frame-type/compiled-return-address)))
 
673
        ((compiled-procedure? return-address)
 
674
         stack-frame-type/interrupt-compiled-procedure)
 
675
        ((compiled-expression? return-address)
 
676
         stack-frame-type/interrupt-compiled-expression)
 
677
        (else
 
678
         (error:bad-range-argument return-address
 
679
                                   'RETURN-ADDRESS->STACK-FRAME-TYPE))))
678
680
 
679
681
(define (initialize-package!)
680
682
  (set! return-address/join-stacklets
687
689
  (set! stack-frame-type/stack-marker
688
690
        (microcode-return/name->type 'STACK-MARKER))
689
691
  (set! stack-frame-type/compiled-return-address
690
 
        (make-stack-frame-type #f #t #f
691
 
                               length/compiled-return-address
 
692
        (make-stack-frame-type #f #t #f length/compiled-return-address
692
693
                               parser/standard-compiled))
693
694
  (set! stack-frame-type/return-to-interpreter
694
695
        (make-stack-frame-type #f #f #t 1 parser/standard))
695
696
  (set! stack-frame-type/special-compiled
696
 
        (make-stack-frame-type #f #t #f
697
 
                               length/special-compiled
 
697
        (make-stack-frame-type #f #t #f length/special-compiled
698
698
                               parser/special-compiled))
699
699
  (set! stack-frame-type/interrupt-compiled-procedure
700
 
        (make-stack-frame-type #f #t #f
701
 
                               length/interrupt-compiled-procedure
 
700
        (make-stack-frame-type #f #t #f length/interrupt-compiled-procedure
702
701
                               parser/standard))
703
702
  (set! stack-frame-type/interrupt-compiled-expression
704
703
        (make-stack-frame-type #f #t #f 1 parser/standard))
705
704
  (set! word-size
706
 
        (let ((initial (system-vector-length (make-bit-string 1 #f))))
 
705
        (let ((b1 (system-vector-length (make-bit-string 1 #f))))
707
706
          (let loop ((size 2))
708
 
            (if (= (system-vector-length (make-bit-string size #f)) initial)
709
 
                (loop (+ size 1))
710
 
                (- size 1)))))
 
707
            (if (fix:= (system-vector-length (make-bit-string size #f)) b1)
 
708
                (loop (fix:+ size 1))
 
709
                (fix:- size 1)))))
711
710
  (set! continuation-return-address #f)
712
711
  unspecific)
713
712
 
723
722
(define (make-stack-frame-types)
724
723
  (let ((types (make-vector (microcode-return/code-limit) #f)))
725
724
 
726
 
    (define (stack-frame-type name subproblem?
727
 
                              history-subproblem?
728
 
                              length parser)
 
725
    (define (stack-frame-type name subproblem? history-subproblem? length
 
726
                              parser)
729
727
      (let ((code (microcode-return name)))
730
 
        (let ((type (make-stack-frame-type code subproblem?
731
 
                                           history-subproblem?
732
 
                                           length parser)))
 
728
        (let ((type
 
729
               (make-stack-frame-type code subproblem? history-subproblem?
 
730
                                      length parser)))
733
731
          (vector-set! types code type)
734
732
          type)))
735
733
 
736
734
    (define (standard-frame name length #!optional parser)
737
 
      (stack-frame-type name
738
 
                        #f
739
 
                        #f
740
 
                        length
741
 
                        (if (default-object? parser)
742
 
                            parser/standard
743
 
                            parser)))
 
735
      (stack-frame-type name #f #f length
 
736
                        (if (default-object? parser) parser/standard parser)))
744
737
 
745
738
    (define (standard-subproblem name length)
746
 
      (stack-frame-type name
747
 
                        #t
748
 
                        #t
749
 
                        length
750
 
                        parser/standard))
 
739
      (stack-frame-type name #t #t length parser/standard))
751
740
 
752
741
    (define (non-history-subproblem name length #!optional parser)
753
 
      (stack-frame-type name
754
 
                        #t
755
 
                        #f
756
 
                        length
757
 
                        (if (default-object? parser)
758
 
                            parser/standard
759
 
                            parser)))
 
742
      (stack-frame-type name #t #f length
 
743
                        (if (default-object? parser) parser/standard parser)))
760
744
 
761
745
    (standard-frame 'RESTORE-INTERRUPT-MASK 2 parser/restore-interrupt-mask)
762
746
    (standard-frame 'RESTORE-HISTORY 4 parser/restore-history)
851
835
(define-integrable hardware-trap/extra-info-index 8)
852
836
 
853
837
(define (length/hardware-trap stream offset)
854
 
  (let ((state (element-stream/ref stream hardware-trap/state-index))
855
 
        (stack-recovered?
856
 
         (element-stream/ref stream hardware-trap/stack-index)))
 
838
  (let ((state (stream-ref stream hardware-trap/state-index))
 
839
        (stack-recovered? (stream-ref stream hardware-trap/stack-index)))
857
840
    (if (not stack-recovered?)
858
841
        hardware-trap/frame-size
859
842
        (let ((after-header (stream-tail stream hardware-trap/frame-size)))
861
844
            ((1)
862
845
             ;; primitive
863
846
             (let* ((primitive
864
 
                     (element-stream/ref stream hardware-trap/pc-info1-index))
 
847
                     (stream-ref stream hardware-trap/pc-info1-index))
865
848
                    (arity (primitive-procedure-arity primitive))
866
849
                    (nargs
867
 
                     (if (negative? arity)
868
 
                         (element-stream/ref stream
869
 
                                             hardware-trap/pc-info2-index)
 
850
                     (if (< arity 0)
 
851
                         (stream-ref stream hardware-trap/pc-info2-index)
870
852
                         arity)))
871
 
               (if (return-address? (element-stream/ref after-header nargs))
 
853
               (if (return-address? (stream-ref after-header nargs))
872
854
                   (+ hardware-trap/frame-size nargs)
873
855
                   (- (heuristic (stream-tail after-header nargs)
874
856
                                 (+ hardware-trap/frame-size nargs offset))
878
860
             (- (heuristic after-header (+ hardware-trap/frame-size offset))
879
861
                offset))
880
862
            (else
881
 
             (error "length/hardware-trap: Unknown state" state)))))))
 
863
             (error "Unknown state:" state)))))))
882
864
 
883
865
(define (heuristic stream offset)
884
866
  (if (or (stream-null? stream)
885
 
          (and (return-address? (element-stream/head stream))
 
867
          (and (return-address? (stream-car stream))
886
868
               (verify 2 stream offset)))
887
869
      offset
888
 
      (heuristic (stream-cdr stream) (1+ offset))))
 
870
      (heuristic (stream-cdr stream) (+ offset 1))))
889
871
 
890
872
(define (hardware-trap-frame? frame)
891
873
  (and (stack-frame? frame)
892
874
       (eq? (stack-frame/type frame)
893
875
            stack-frame-type/hardware-trap)))
894
876
 
 
877
(define-guarantee hardware-trap-frame "hardware-trap frame")
 
878
 
895
879
(define (hardware-trap-frame/code frame)
896
 
  (guarantee-hardware-trap-frame frame)
 
880
  (guarantee-hardware-trap-frame frame 'hardware-trap-frame/code)
897
881
  (let ((code (stack-frame/ref frame hardware-trap/code-index)))
898
882
    (cond ((pair? code) (cdr code))
899
883
          ((string? code) code)
900
884
          (else #f))))
901
 
 
902
 
(define (guarantee-hardware-trap-frame frame)
903
 
  (if (not (hardware-trap-frame? frame))
904
 
      (error "guarantee-hardware-trap-frame: invalid" frame)))
905
885
 
906
886
(define (hardware-trap-frame/print-registers frame)
907
 
  (guarantee-hardware-trap-frame frame)
 
887
  (guarantee-hardware-trap-frame frame 'hardware-trap-frame/print-registers)
908
888
  (let ((block (stack-frame/ref frame hardware-trap/extra-info-index)))
909
889
    (if block
910
890
        (let ((nregs (- (system-vector-length block) 2)))
917
897
                                  (+ 2 i)
918
898
                                  (string-append "register "
919
899
                                                 (number->string i)))
920
 
                  (loop (1+ i)))))))))
 
900
                  (loop (+ i 1)))))))))
921
901
 
922
902
(define (print-register block index name)
923
903
  (let ((value
924
904
         (let ((bit-string (bit-string-allocate word-size)))
925
 
           (read-bits! block (* word-size (1+ index)) bit-string)
 
905
           (read-bits! block (* word-size (+ index 1)) bit-string)
926
906
           (bit-string->unsigned-integer bit-string))))
927
907
    (newline)
928
908
    (write-string "  ")
933
913
(define word-size)
934
914
 
935
915
(define (hardware-trap-frame/print-stack frame)
936
 
  (guarantee-hardware-trap-frame frame)
 
916
  (guarantee-hardware-trap-frame frame 'hardware-trap-frame/print-stack)
937
917
  (let ((elements
938
918
         (let ((elements (stack-frame/elements frame)))
939
919
           (subvector->list elements
962
942
        (write-string (number->string value #x10)))))
963
943
 
964
944
(define (hardware-trap-frame/describe frame long?)
965
 
  (guarantee-hardware-trap-frame frame)
 
945
  (guarantee-hardware-trap-frame frame 'hardware-trap-frame/describe)
966
946
  (let ((name (stack-frame/ref frame hardware-trap/signal-name-index))
967
947
        (state (stack-frame/ref frame hardware-trap/state-index)))
968
948
    (if (not name)
1025
1005
                   (write-string " in unknown compiled-code utility ")
1026
1006
                   (write-hex index)))))
1027
1007
          (else
1028
 
           (error "hardware-trap/describe: Unknown state" state))))))
 
 
b'\\ No newline at end of file'
 
1008
           (error "Unknown state:" state))))))
 
 
b'\\ No newline at end of file'