smalltalk-tng
view r1/interp.scm @ 323:454c18798969
merger
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Tue Feb 07 11:34:20 2012 -0500 (3 months ago) |
| parents | |
| children |
line source
1 (require 'srfi-1)
3 (require 'util)
4 (require 'parsetng)
6 ;; This is just documentation. It's not used anywhere.
7 (define %location-protocol
8 '(namespace-traits
9 (loc at: sym)
10 (loc at: sym put: val)
12 continuation-traits
13 (loc return: val)
14 (loc raise: exn)
16 required-continuation-traits
17 (loc continuation-cell)
19 concurrency-traits
20 (loc parent)
21 (loc children-cell)))
23 (define runnable-suspensions '())
24 ;;(define runnable-suspension-counter 0)
25 (define current-location #f)
27 (define (metalevel-work-available?)
28 (not (null? runnable-suspensions)))
30 (define (metalevel-resume-thread! suspension value)
31 ;;(set! runnable-suspension-counter (+ runnable-suspension-counter 1))
32 (push! runnable-suspensions (lambda () (suspension value))))
34 (define (metalevel-location-alive? location)
35 (or (eq? *nil* location)
36 (*false*? (get-slot location 'dead))))
38 (define (metalevel-unsuspend location thunk)
39 (if (metalevel-location-alive? location)
40 (begin
41 (set! current-location location)
42 (thunk))
43 (metalevel-schedule!!)))
45 (define (metalevel-spawn location thunk)
46 ;;(set! runnable-suspension-counter (+ runnable-suspension-counter 1))
47 (push! runnable-suspensions (lambda () (metalevel-unsuspend location thunk))))
49 (define (metalevel-suspend-thread receiver)
50 (call-with-current-continuation
51 (lambda (k)
52 (let ((location current-location))
53 (receiver (lambda (v) (metalevel-unsuspend location (lambda () (k v)))))
54 (metalevel-schedule!!)))))
56 (define metalevel-root-continuation #f)
57 (define (metalevel-schedule!!)
58 (metalevel-root-continuation 'throw))
60 (define -metalevel-running #t)
61 (define (metalevel-stop!)
62 (set! -metalevel-running #f))
63 (define (metalevel-stopped?)
64 (not -metalevel-running))
66 (define (metalevel-run-runnable-suspensions next-event-time)
67 (call-with-current-continuation
68 (lambda (restart-mainloop)
69 (set! metalevel-root-continuation restart-mainloop)))
70 ;;(write (list "Suspensions: "runnable-suspension-counter))(newline)
71 (do ()
72 ((or (and next-event-time (>= (get-time-of-day) next-event-time))
73 (not -metalevel-running)
74 (not (metalevel-work-available?))))
75 (let ((suspension (car runnable-suspensions)))
76 ;;(set! runnable-suspension-counter (- runnable-suspension-counter 1))
77 (set! runnable-suspensions (cdr runnable-suspensions))
78 (suspension)))
79 (let ((now (get-time-of-day)))
80 (if (and next-event-time
81 (< now next-event-time))
82 (sdl-delay (truncate (* (- next-event-time now) 1000.0))))))
84 (define (metalevel-suspend-on-cell c)
85 (metalevel-suspend-thread
86 (lambda (suspension)
87 (set-slot! c 'queue (cons suspension (get-slot c 'queue))))))
89 (define (metalevel-peek-cell-value c)
90 (let ((val (get-slot c '_pvt_value)))
91 (if (eq? val *no-role*)
92 (let ((newval (metalevel-suspend-on-cell c)))
93 (set-slot! c '_pvt_value newval)
94 newval)
95 val)))
97 (define (metalevel-extract-cell-value c)
98 (let ((val (get-slot c '_pvt_value)))
99 (if (eq? val *no-role*)
100 (metalevel-suspend-on-cell c)
101 (begin
102 (set-slot! c '_pvt_value *no-role*)
103 val))))
105 (define (metalevel-inject-cell-value c v)
106 (if (eq? (get-slot c '_pvt_value) *no-role*)
107 (let ((q (get-slot c 'queue)))
108 (if (pair? q)
109 (let ((suspension (car q))
110 (remainder (cdr q)))
111 (set-slot! c 'queue remainder)
112 (metalevel-resume-thread! suspension v))
113 (set-slot! c '_pvt_value v))
114 *nil*)
115 (metalevel-raise-exception (list 'cellOverflow c))))
117 (define (extend-env name val env)
118 (cons (cons name val) env))
120 (define metalevel-raise-exception error)
122 (define metalevel-interpret
123 (let ()
124 (define (do-local resend env lit instr)
125 (cdr (assq (vector-ref instr 1) env)))
127 (define (do-global resend env lit instr)
128 (let ((dict (metalevel-peek-cell-value *globals*)))
129 (send/previous-method #f (vector-ref instr 1) (vector dict))))
131 (define (eval-in-par thunk)
132 (let* ((cell (clone-object *cell*))
133 (loc (clone-object *location*)))
134 (set-slot! loc 'continuation cell)
135 (set-slot! loc 'parent current-location)
136 (set-slot! current-location 'children (cons loc (get-slot current-location 'children)))
137 (metalevel-spawn loc (lambda () (metalevel-inject-cell-value cell (thunk))))
138 cell))
140 (define (eval-tuple resend env lit instrs)
141 (let ((num-instrs (vector-length instrs)))
142 (if (= num-instrs 1)
143 (vector (vm resend env lit (vector-ref instrs 0)))
144 (let ((vals (make-vector num-instrs))
145 (flags (make-vector num-instrs)))
146 (do ((index 0 (+ index 1)))
147 ((= index num-instrs))
148 (let* ((instr (vector-ref instrs index))
149 (kind (vector-ref instr 0))
150 (flag (or (eq? kind 'local)
151 (eq? kind 'literal))))
152 (vector-set! flags index flag)
153 (vector-set! vals index
154 (if flag
155 (vm resend env lit instr)
156 (eval-in-par (lambda () (vm resend env lit instr)))))))
157 (do ((index 0 (+ index 1)))
158 ((= index num-instrs))
159 (if (not (vector-ref flags index))
160 (vector-set! vals index
161 (metalevel-peek-cell-value (vector-ref vals index)))))
162 vals))))
164 (define (do-send resend env lit instr)
165 (let ((selector (vector-ref instr 1))
166 (vals (eval-tuple resend env lit (vector-ref instr 2))))
167 (debug 2 --> 0 "Send "selector" "vals)
168 (let ((result (send/previous-method #f selector vals)))
169 (debug 2 --> 0 "Rslt "selector" "vals" ==> "result)
170 result)))
172 (define (do-closure resend env lit instr)
173 (let* ((block (clone-object (vector-ref lit (vector-ref instr 1)))))
174 (set-slot! block 'environment env)
175 block))
177 (define (do-begin resend env lit instr)
178 (eval-statements resend env lit (vector-ref instr 1)))
180 (define (do-scope resend env lit instr)
181 (let* ((name (vector-ref instr 1))
182 (cell (eval-in-par (lambda ()
183 (let ((newenv (extend-env name current-location env)))
184 (eval-statements resend newenv lit (vector-ref instr 2)))))))
185 (metalevel-peek-cell-value cell)))
187 (define (do-literal resend env lit instr)
188 (vector-ref lit (vector-ref instr 1)))
190 (define (do-update resend env lit instr)
191 (let* ((o (clone-object (vm resend env lit (vector-ref instr 1))))
192 (updates (vector-ref instr 2))
193 (n (vector-length updates)))
194 (do ((i 0 (+ i 1)))
195 ((= i n))
196 (let ((update (vector-ref updates i)))
197 (let ((delegating (eq? (vector-ref update 0) *true*))
198 (name (vector-ref update 1))
199 (update-instr (vector-ref update 2)))
200 (let ((val (vm resend env lit update-instr)))
201 (if (has-slot? o name)
202 (set-slot! o name val)
203 (add-slot! o name val delegating 'immutable))))))
204 o))
206 (define (do-tuple resend env lit instr)
207 (eval-tuple resend env lit (vector-ref instr 1)))
209 (define (do-resend resend env lit instr)
210 (resend))
212 (define (do-method resend env lit instr)
213 (let ((selector (vector-ref instr 1))
214 (formals (vector-ref instr 2))
215 (specializer-instrs (vector-ref instr 3))
216 (body-object (vector-ref instr 4))
217 (method-litvec (vector-ref instr 5)))
218 (let* ((specializers (map (lambda (specializer-instr)
219 (vm resend env lit specializer-instr))
220 (vector->list specializer-instrs)))
221 (method (define-method! selector formals specializers body-object)))
222 (set-slot! method 'literals method-litvec)
223 *nil*)))
225 (define (eval-statement resend env lit statement k)
226 (if (eq? (vector-ref statement 0) 'bind)
227 (let* ((name (vector-ref statement 1))
228 (instr (vector-ref statement 2))
229 (newenv (extend-env name *nil* env))
230 (value (vm resend newenv lit instr)))
231 (set-cdr! (car newenv) value)
232 (k newenv value))
233 (k env (vm resend env lit statement))))
235 (define (eval-statements resend env lit statements)
236 (let ((n (vector-length statements)))
237 (let loop ((env env)
238 (i 0)
239 (acc *nil*))
240 (if (= i n)
241 acc
242 (eval-statement resend env lit (vector-ref statements i)
243 (lambda (newenv value)
244 (loop newenv (+ i 1) value)))))))
246 (define optable (make-hash-table eq?))
248 (define (vm resend env lit instr)
249 (debug 1 --> 0 "Eval "instr)
250 (debug 2 --> 0 "Env= "env)
251 (let ((result ((hash-table-ref optable (vector-ref instr 0)
252 (lambda _ (error "Unknown instruction" instr)))
253 resend env lit instr)))
254 (debug 2 --> 0 "Done "instr" ==> "result)
255 result))
257 (hash-table-set! optable 'local do-local)
258 (hash-table-set! optable 'global do-global)
259 (hash-table-set! optable 'send do-send)
260 (hash-table-set! optable 'closure do-closure)
261 (hash-table-set! optable 'begin do-begin)
262 (hash-table-set! optable 'scope do-scope)
263 (hash-table-set! optable 'literal do-literal)
264 (hash-table-set! optable 'update do-update)
265 (hash-table-set! optable 'tuple do-tuple)
266 (hash-table-set! optable 'resend do-resend)
267 (hash-table-set! optable 'method do-method)
269 vm))
271 (define (metalevel-eval-method code method argv)
272 (let* ((litvec (get-slot method 'literals))
273 (prologue (car code))
274 (instruction (cdr code))
275 (need-block-environment? (eq? *true* (vector-ref prologue 1))))
276 (bump-invocation-count! prologue method)
277 (metalevel-interpret (if need-block-environment?
278 #f
279 (lambda ()
280 (send/previous-method method (get-slot method 'selector) argv)))
281 (fold extend-env
282 (if need-block-environment?
283 (get-slot (vector-ref argv 0) 'environment)
284 '())
285 (get-slot method 'arguments)
286 (vector->list argv))
287 litvec
288 instruction)))
290 (define (metalevel-eval ast)
291 (let-values (((instr litvec) (compile-ThiNG ast)))
292 (metalevel-interpret #f '() litvec instr)))
294 (define (ThiNG-load-file filename)
295 (let-values (((success ast) (call-with-input-file filename
296 (lambda (port)
297 (parse-ThiNG filename
298 ThiNG-parser
299 (lambda () (read-char port)))))))
300 (if success
301 (cons *true* (metalevel-eval `(scope ,*nil* ,ast)))
302 (cons *false* ast))))