1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber, Martin Gasbichler
; This is file resume.scm.
(define (s48-initialize-vm stack-begin stack-size)
(install-symbols!+gc (s48-initial-symbols))
(install-shared-bindings!+gc (s48-initial-imported-bindings)
(s48-initial-exported-bindings))
(initialize-external-events)
(initialize-stack+gc stack-begin stack-size)
(initialize-interpreter+gc)
(initialize-bignums)
(initialize-proposals!+gc))
;----------------
; Push the arguments to the initial procedure (a vector of strings passed
; in from the outside and the three standard channels) and call it.
; The argument list needs to be in sync with MAKE-USUAL-RESUMER in
; rts/init.scm, and MAKE-STARTUP-PROCEDURE in bcomp/comp.scm.
(define (s48-call-startup-procedure startup-vector startup-vector-length)
(clear-registers)
(push (enter-startup-argument+gc startup-vector startup-vector-length))
(receive (input input-encoding output output-encoding error error-encoding)
(initialize-i/o-system+gc)
(push input)
(push input-encoding)
(push output)
(push output-encoding)
(push error)
(push error-encoding)
(push (s48-resumer-records))
(s48-initialization-complete!)
(s48-restart (s48-startup-procedure) 8)))
(define (enter-startup-argument+gc startup-vector startup-vector-length)
(let* ((argv-total-bytes-count
(let loop ((i 0) (count 0))
(if (= i startup-vector-length)
count
(goto loop
(+ 1 i)
(+ count (+ (string-length (vector-ref startup-vector i)) 1))))))
(key (ensure-space
(+ stob-overhead startup-vector-length
(* startup-vector-length stob-overhead)
(bytes->cells argv-total-bytes-count))))
(vector (make-d-vector (enum stob vector) startup-vector-length key)))
(natural-for-each (lambda (i)
(vm-vector-set! vector
i
(enter-os-string-byte-vector
(vector-ref startup-vector i)
key)))
startup-vector-length)
vector))
(define (enter-os-string-byte-vector s key)
(let* ((len (string-length s))
(vec (make-code-vector (+ len 1) key))) ; NUL
(do ((i 0 (+ 1 i)))
((> i len) vec)
(code-vector-set! vec i (char->ascii (string-ref s i))))))
;----------------
; Restart the interpreter, calling PROC with NARGS arguments already on the
; stack.
(define (s48-restart proc nargs)
(cond ((closure? proc)
(set-val! proc)
(let ((retval (perform-application nargs)))
;; This is necessary to remove the stack from a callback
;; from C. If we don't do this, a single callback works,
;; but two in a row fails. I'm not sure if this is the
;; right place for this fix. --Mike
(remove-current-frame)
retval))
(else
(error "s48-restart called with non-procedure" proc))))
|
