Some more instructions tested, added reentrant call's that are needed for instruction...
[aschm:aschm.git] / module / native / vm / inst.scm
1 (define-module (native vm inst)
2   #:use-module (native vm base)
3   #:use-module (native vm bit-utilities)
4   #:use-module (native vm inject)
5   #:use-module (native vm vm)
6   #:use-module (native vm program)
7   #:use-module (native vm variable)
8   #:use-module (native vm vector)
9   #:use-module (native vm struct)
10   #:use-module (native vm c-callers)
11   #:use-module (native vm c-call)
12   #:use-module (native aschm)
13   #:use-module (native vm constants))
14
15 ;-------------------------------------------------------------------------------
16 ;-
17
18 (define-syntax-rule (return-block code ...)
19   (assemble ()
20     (inst mov reg1 (&& cont13:))
21     (inst mov (ret) reg1)
22     code ...
23   cont13:))
24
25
26 (define (push-regs)
27   (assemble ()
28     (inst push reg1)
29     (inst push reg2)
30     (inst push reg3)
31     (inst push reg4)
32     (inst push reg5)
33     (inst push call-1)
34     (inst push call-2)
35     (inst push call-3)
36     (inst push call-4)
37     (inst push call-5)    
38     (inst push call-6)))
39
40 (define (pop-regs)
41   (assemble ()
42     (inst pop call-6)
43     (inst pop call-5)
44     (inst pop call-4)
45     (inst pop call-3)
46     (inst pop call-2)    
47     (inst pop call-1)
48     (inst pop reg5)
49     (inst pop reg4)
50     (inst pop reg3)
51     (inst pop reg2)
52     (inst pop reg1)))
53
54
55
56
57 (define (inum reg1)
58   (assemble ()
59     (inst lea reg1 (make-ea #:qword #:disp 2 #:index reg1 #:scale 4))))
60
61 #;
62 (define-vm-inst halt 0 ((U8_U24 src)))
63   
64 #;
65 (define-vm-inst halt/values 1 ((U8_U24 src)))
66
67 ;;This is a bit number magic needs to be abstracted in order to be
68 ;;more robust depends on a fixed layout of scm_i_thread
69 (define (handle-interupts reg4 . regs)
70   (assemble ()
71     (inst inc rbx)
72     (inst cmp rbx 10)
73     (inst jmp #:l out:)
74     (inst call (interupt-hook jmp))
75    out:))
76
77 (define-jmp-hook interupt-hook
78   (inst mov rbx 0)
79   (inst push reg4)
80   (inst mov reg4 (cur_th))
81   (inst mov reg4 (Q reg4 th->pending_asyncs))
82   (inst test reg4 reg4)
83   (inst jmp #:z out:)
84   (push-regs)
85   (c-call scm_async_click)
86   (pop-regs)
87  out:
88   (inst pop reg4)
89   (inst ret))
90
91 ;;F R E E    V A R I A B L E S
92 (define (free-variable-ref reg x) (Q reg (+ x 2)))
93 (define (check-free-variable reg1) #f)
94
95 ;; H O O K S
96 (define vm-use-hooks             #f)
97 (define apply-hook-i             0)
98 (define push-continuation-hook-i 1)
99 (define pop-continuation-hook-i  2)
100
101
102 (define (run-hook reg1 regs h args n)
103   (when vm-use-hooks
104     (assemble ()
105       (inst mov reg1 (vm-trace-level))
106       (inst test reg1 reg1)
107       (inst jmp #:z out:)
108       (for-each (lambda (reg) (assemble () (inst push reg))) regs)
109       (c-call ???)
110       (for-each (lambda (reg) (assemble () (inst pop reg))) (reverse regs))
111      out:)))
112     
113 (define (run-hook0 reg regs h) (run-hook reg regs h '() 0))
114 (define (push-continuation-hook reg . regs) 
115   (run-hook0 reg regs push-continuation-hook-i))
116 (define (pop-continuation-hook reg . regs) 
117   (run-hook0 reg regs pop-continuation-hook-i))
118 (define (apply-hook reg . regs)      
119   (run-hook0 reg regs apply-hook-i))
120
121 (define (check-overflow reg reg2)
122   (assemble ()
123     (inst mov reg2 (vm-stack-limit))
124     (inst cmp reg reg2)
125     (inst jmp #:l out:)
126     (inst mov call-1 vm)
127     (c-call g_vm_error_stack_overflow)
128    out:))
129
130 (define (alloc-frame nlocal narg reg1 reg2)
131   (assemble ()
132    (inst lea reg1 (Q rbp   0 nlocal 8))
133    (inst lea reg1 (Q reg1  0 narg   8))
134    (inst mov (vm-rsp) reg1)
135    (check-overflow reg1 reg2)))
136
137 ;Not tested yet
138 (define-vm-inst vm-call 2 ((U8_U24 from) 
139                            (X8_U24 proc) 
140                            (X8_R24 nargs)
141                            (Label  mvret (+ 4 nargs))
142                            (N      args nargs))
143                        
144
145   (inst mov reg2 (local-ref rbp proc))
146   (inst mov reg1 rbp)
147   (inst lea rbp  (Q rbp (+ 4 from)))
148   (inst mov (dynamic-link rbp) reg1)
149   (inst mov reg1 (&& mvret))
150   (inst mov (mv-return-a  rbp) reg1)
151   (inst mov reg1 (&& out:))
152   (inst mov (return-a rbp) reg1)
153   (inst mov reg1 nargs)
154   
155   (for-each 
156    (lambda (src-i dest-i)
157      (inst mov reg3 (local-ref reg1 src-i))
158      (inst mov (local-ref dest-i) reg3))
159    args
160    (iota nargs))
161
162   (if (< nargs 10)
163       (inst jmp (call-hook jmp))
164       (call-rest))
165  out:)
166
167 (define (call-rest)
168   (assemble ()
169     #;
170     (alloc-frame reg1 call-1 call-2 rbp) 
171   
172
173     (NATIVE-PROGRAM? reg2 reg1 nonative:)  
174     (inst mov (program-a rbp) reg2)
175
176     (handle-interupts       reg2 reg1)
177     (push-continuation-hook reg2 reg1)
178     (apply-hook             reg2 reg1)
179
180     (inst jmp reg1)
181   
182    nonative:
183     (handle-interupts       reg1 reg2)
184     (push-continuation-hook reg1 reg2)
185     (apply-hook             reg1 reg2)
186     
187     #;
188     (inst jmp (apply-extra jmp))))
189
190 (define-jmp-hook call-hook (call-rest))
191
192 ;;Not tested yet
193 (define-vm-inst vm-call/values 3 ((U8_U24 from) 
194                                   (X8_U24 proc) 
195                                   (Label  mvret 3))
196
197   (inst mov reg2 (local-ref rbp proc))
198   (inst mov reg1 rbp)
199   (inst lea rbp  (Q rbp (+ 4 from)))
200   (inst mov (dynamic-link rbp) reg1)
201   (inst mov reg1 (&& mvret))
202   (inst mov (mv-return-a  rbp) reg1)
203   (inst mov reg1 (&& out:))
204   (inst mov (return-a rbp) reg1)
205
206   (inst mov reg1 (vm-rsp)) 
207   (inst sub reg1 rbp)
208   (inst shr reg1 4)
209   (inst mov (vm-nargs) reg1)
210   (inst jmp (call-hook jmp))
211  out:)
212
213
214
215 ;;Not implemented non native tail calls
216 (define-vm-inst vm-tail-call 4 ((U8_U24 nargs) 
217                                 (X8_U24 proc))
218   (inst mov reg1 nargs)
219   (inst mov reg2 (local-ref proc))
220   (inst jmp (tail-call-hook jmp)))
221   
222
223 (define-jmp-hook tail-call-hook (tail-part))
224
225 (define (tail-part)
226   (assemble ()
227     (inst mov (program-ref rbp) reg2)
228     (inst mov (vm-nargs) reg1)
229     (inst lea reg1 (Q rbp -1 reg1  8))
230     (inst mov (vm-rsp) reg1)
231
232     (NATIVE-PROGRAM? reg2 reg1 nonative:)  
233     
234     (handle-interupts reg2 reg1)    
235     (apply-hook reg2 reg1)
236
237     (inst jmp reg1)
238
239    nonative:
240     (handle-interupts reg1 reg2)    
241     (apply-hook       reg1 reg2)
242     #;(inst jmp (apply-hook jmp))))
243
244
245
246 (define-vm-inst vm-return 5 ((U8_U24 src))
247   (inst mov reg1 (local-ref src))
248   (inst jmp (return-hook jmp)))
249
250 (define-jmp-hook return-hook
251   (inst lea reg2 (lower-adress rbp))
252   (inst mov reg3 (return-a rbp))
253   (inst mov rbp  (dynamic-link rbp))
254   (inst mov (Q reg2) reg1)
255   (inst add reg2 8)
256   (inst mov (vm-rsp) reg2)
257
258   ;(pop-continuation-hook reg1 reg3)
259   (handle-interupts reg1 reg3)
260
261   (inst jmp reg3))
262
263
264 (define-vm-inst vm-return/values 6 ((U8_U24 nargs))
265   (inst lea reg1 (Q rbp (- nargs 1)))
266   (inst mov (vm-rsp) reg1)
267   (inst jmp (values-hook jmp)))
268
269 (define-jmp-hook values-hook
270   (handle-interupts reg1)
271
272   ;;(pop-continuation-hook reg1)
273   (inst mov reg1 rbp)
274   (inst mov reg2 (mv-return-a rbp))
275   (inst mov rbp  (dynamic-link rbp))
276   (inst mov (Q reg1 -1) SCM_BOOL_F)
277   (inst mov (Q reg1 -2) SCM_BOOL_F)
278   (inst mov (Q reg1 -3) SCM_BOOL_F)
279   (inst mov (Q reg1 -4) SCM_BOOL_F)
280   
281   (inst jmp reg2))
282
283 #;
284 (define-vm-inst vm-subr-call 7 ((U8_U12_U12 nargs ptr))
285   (handle-interupts reg2)
286
287   (inst mov reg1 (local-ref ptr))
288   (inst mov reg1 (Q reg1 1))  
289   
290   (if (> nargs 0) (assemble () (inst mov call-1 (Q rbp 0))))
291   (if (> nargs 1) (assemble () (inst mov call-2 (Q rbp 1))))
292   (if (> nargs 2) (assemble () (inst mov call-3 (Q rbp 2))))
293   (if (> nargs 3) (assemble () (inst mov call-4 (Q rbp 3))))
294   (if (> nargs 4) (assemble () (inst mov call-5 (Q rbp 4))))
295   (if (> nargs 5) (assemble () (inst mov call-6 (Q rbp 5)))) 
296
297   (for-each 
298    (lambda (n) (assemble () (inst push (Q rbp n))))
299    (map (lambda (x) (+ x 6)) (iota (max 0 (- nargs 6)))))
300   (c-call reg1)
301   (if (> nargs 6) (inst add rsp (* (- nargs 6) 8)))
302   ;;(inst mov reg3 (return-hook jmp))
303   #;(STRUCT? reg1 reg2 reg3 scm_values_vtable values:)
304   (inst mov reg2 (Q reg1 1))
305   #;...mv...)
306
307
308
309 #;
310 (define-vm-inst foreign_call 8 ())
311
312 #;
313 (define-vm-inst continuation_call 9 ())
314
315 #;
316 (define-vm-inst partial_cont_call 10 ())
317
318 #;
319 (define-vm-inst vm-apply 11 ())
320
321 #;
322 (define-vm-inst vm-call-cc 12 ())
323
324
325 ;; not tested yet
326 (define-vm-inst vm-values 13 ((U8_X24))
327   (inst jmp (values-hook jmp)))
328
329
330 (define-syntax-rule (br-nargs nm n rel)
331   (define-vm-inst nm n ((U8_U24 expected) 
332                         (X8_L24 offset)
333                         (Label label offset))
334     (inst mov reg1 (vm-nargs))
335     (inst cmp reg1 expected)
336     (inst jmp rel label)))
337
338 (br-nargs br-if-nargs-ne 14 #:ne)
339 (br-nargs br-if-nargs-lt 15 #:l)
340 (br-nargs br-if-nargs-gt 16 #:g)
341
342
343
344 (define-syntax-rule (assert-narg nm n op)
345   (define-vm-inst nm n ((U8_U24 expected))
346     (inst mov reg1 (vm-nargs))
347     (inst cmp reg1 expected)
348     (inst jmp op out:)
349     (inst mov call-1 reg1)
350     (c-call scm_wrong_argument)
351    out:))
352
353 (assert-narg assert-nargs-ee 17 #:eq)
354 (assert-narg assert-nargs-ge 18 #:ge)  
355
356 ; not tested yet
357 (define-vm-inst reserve-locals 19 ((U8_U24 nlocals))
358   (inst mov reg3 nlocals)
359   (inst call (reserve-hook jmp)))
360
361 (define-jmp-hook reserve-hook
362   (inst mov reg1 (vm-nargs))
363   (alloc-frame reg3 reg1 reg2 reg4)
364  loop:
365   (inst test reg3 reg3)
366   (inst jmp #:z out:)
367   (inst sub reg2 8)
368   (inst dec reg3)
369   (inst mov (Q reg2) SCM_UNDEFINED)
370   (inst jmp loop:)
371  out:
372   (inst ret))
373
374
375 (define-vm-inst assert-nargs-ee/locals 20 ((U8_U12_U12 expected nlocals))
376   (inst mov reg3 nlocals)
377   (inst mov reg4 expected)
378   (inst call (a-n-e/locals-hook jmp)))
379
380 (define-jmp-hook a-n-e/locals-hook
381   (inst mov reg1 (vm-nargs))
382   (inst cmp reg1 reg4)
383   (inst jmp #:eq cont:)   
384   (inst mov call-1 reg1)
385   (c-call scm_wrong_argument)
386  cont:
387   (inst call (reserve-hook jmp))
388   (inst ret))
389   
390
391 #;
392 (define-vm-inst bind-kwargs 21 ())
393
394 ;;TODO, check that the decreasing of nargs is not global
395 (define-vm-inst bind-rest 22 ((U8_U24 dst))
396   (inst mov reg3 dst)
397   (inst call (bind-rest-hook jmp)))
398
399 (define-jmp-hook bind-rest-hook
400     (inst mov reg2 (vm-nargs))
401     (inst mov reg1 SCM_EOL)
402   loop:
403     (inst cmp reg2 reg3)
404     (inst jmp #:le out:)
405     (inst dec reg2)
406     (inst mov call-1 (local-ref rbp 0 reg2 8))
407     (inst mov call-2 reg1)
408     (c-call scm_cons)
409     (inst jmp loop:)
410   out:
411     (inst lea reg2  (local-ref rbp 0 reg3 8))
412     (inst mov (Q reg2) reg1)
413     (inst add reg2 8)
414     (inst mov (vm-rsp) reg2)
415     (inst ret))
416
417 ;; not tested yet
418 (define-vm-inst drop-values 23 ((U8_U24 nlocals))
419   (inst mov reg1 (Q rbp nlocals))
420   (inst mov (vm-rsp) reg1))
421
422 (define-vm-inst br 24 ((U8_L24 offset) (Label label offset))
423   (if (< offset 0)
424       (begin
425         (handle-interupts reg1)
426         (inst jmp label))
427       (inst jmp label)))
428
429 (define (succ f)
430   (case f
431     ((#:eq) #:ne)
432     ((#:ne) #:eq)
433     ((#:z)  #:nz)
434     ((#:nz) #:z)
435     ((#:l)  #:ge)
436     ((#:le) #:g)
437     ((#:g)  #:le)
438     ((#:ge) #:l)))
439
440 (define (id x) x)
441
442 (define-syntax-rule (br-unary nm n reg (test c) out: f)
443   (define-vm-inst nm n ((U8_U24 x) 
444                         (U1_X7_L24  bit offset)
445                         (Label label offset))
446     (let ((fail (if (zero? bit) id succ)))
447       (assemble ()
448          (inst mov reg (local-ref x))
449          (inst test reg c)
450          (inst jmp (fail f) out:)
451          (if (< offset 0) (handle-interupts reg))
452          (inst jmp label)
453         out:))))
454
455
456 (br-unary br-if-true 25 reg1 (cmp SCM_BOOL_F    ) out: #:eq)
457 (br-unary br-if-null 26 reg1 (cmp SCM_EOL       ) out: #:ne)
458 (br-unary br-if-nil  27 reg1 (cmp SCM_ELISP_NIL ) out: #:ne)
459
460
461 (define-syntax-rule (br-unary* nm n reg (tst c) out: f code ...)
462  (define-vm-inst nm n ((U8_U24 x) 
463                        (U1_X7_L24  bit offset)
464                        (Label label offset))
465    (if (zero? bit)
466        (assemble ()
467          (inst mov reg (local-ref x))
468          (inst test reg 7)
469          (inst jmp #:nz out:)
470          code ...
471          (inst tst reg c)
472          (inst jmp f out:)
473          (if (< offset 0) (handle-interupts reg1))
474          (inst jmp label)
475         out:)
476        (assemble ()
477          (inst mov reg (local-ref x))
478          (inst test reg 7)
479          (inst jmp #:nz ret:)
480          code ...
481          (inst tst reg c)
482          (inst jmp (succ f) out:)
483         ret:
484          (if (< offset 0) (handle-interupts reg1))
485          (inst jmp label)
486         out:))))
487
488 (define-syntax-rule (br-unary+ nm n reg (tst c) out: f code ...)
489  (define-vm-inst nm n ((U8_U24 x) 
490                        (U1_X7_L24  bit offset)
491                        (Label label offset))
492    (if (zero? bit)
493        (assemble ()
494          (inst mov reg (local-ref x))
495          code ...
496          (inst tst reg c)
497          (inst jmp f out:)
498          (if (< offset 0) (handle-interupts reg1))
499          (inst jmp label)
500         out:)
501        (assemble ()
502          (inst mov reg (local-ref x))
503          code ...
504          (inst tst reg c)
505          (inst jmp (succ f) out:)
506         ret:
507          (if (< offset 0) (handle-interupts reg1))
508          (inst jmp label)
509         out:))))
510
511 (define-syntax-rule (br-unary** nm n reg tc7 (tst c) out: f code ...)
512  (define-vm-inst nm n ((U8_U24 x) 
513                        (U1_U7_L24 bit tc7 offset)
514                        (Label label offset))
515    (if (zero? bit)
516        (assemble ()
517          (inst mov reg (local-ref x))
518          (inst test reg 7)
519          (inst jmp #:nz out:)
520          (inst mov reg (Q reg))
521          (inst and reg #x7f)
522          code ...
523          (inst tst reg c)
524          (inst jmp f out:)
525          (if (< offset 0) (handle-interupts reg))
526          (inst jmp label)
527         out:)
528        (assemble ()
529          (inst mov reg (local-ref x))
530          (inst test reg 7)
531          (inst jmp #:nz ret:)
532          (inst mov reg (Q reg))
533          (inst and reg #x7f)
534          code ...
535          (inst tst reg c)
536          (inst jmp (succ f) out:)
537         ret:
538          (if (< offset 0) (handle-interupts reg))
539          (inst jmp label)
540         out:))))
541
542 (br-unary* br-if-pair   28 reg1 (test 1) out: #:nz
543            (inst mov reg1 (Q reg1)))
544
545
546 (br-unary* br-if-struct 29 reg1 (cmp tc3_struct) out: #:ne
547            (inst mov reg1 (Q reg1))
548            (inst and reg1 #x7))
549
550 (br-unary+ br-if-char 30 reg1  (cmp tc8_char) out: #:ne
551            (inst and reg1 #xff))
552
553 (br-unary** br-if-tc7 31 reg1 tc7  (cmp tc7) out: #:ne)
554
555
556 (define-vm-inst br-if-eq 32 ((U8_U12_U12 x y) 
557                              (U1_X7_L24 neg offset)
558                              (Label label offset))
559   (let ((op (if (= neg 1) #:eq #:ne)))
560     (assemble ()
561       (inst mov reg1 (local-ref x))
562       (inst mov reg2 (local-ref y))
563       (inst cmp reg1 reg2)
564       (inst jmp op out:)
565       (if (< offset 0) (handle-interupts reg1))
566       (inst jmp label)
567      out:)))
568
569
570 (define-syntax-rule (br-cmp nm n scm_eqv_p)
571   (define-vm-inst nm n ((U8_U12_U12 x y) 
572                         (U1_X7_L24 neg offset)
573                         (Label label offset))
574   (inst mov call-1 (local-ref x))
575   (inst mov call-2 (local-ref y))
576   (if (= neg 0)
577       (assemble ()
578         (inst cmp call-1 call-2)
579         (inst jmp #:eq go:)
580         (inst test call-1 7)
581         (inst jmp #:nz out:)
582         (inst test call-2 7)
583         (inst jmp #:nz out:)
584         (c-call scm_eqv_p)
585         (inst cmp reg1 SCM_BOOL_F)
586         (inst jmp #:eq out:)
587        go:
588         (if (< offset 0) (handle-interupts reg1))
589         (inst jmp label)
590        out:)
591       (assemble ()
592         (inst cmp call-1 call-2)
593         (inst jmp #:eq out:)
594         (inst test call-1 7)
595         (inst jmp #:nz go:)
596         (inst test call-2 7)
597         (inst jmp #:nz go:)
598         (c-call scm_eqv_p)
599         (inst cmp reg1 SCM_BOOL_F)
600         (inst jmp #:ne out:)
601        go:
602         (if (< offset 0) (handle-interupts reg1))
603         (inst jmp label)
604        out:))))
605
606 (br-cmp br-if-eqv   33 scm_eqv_p)
607 (br-cmp br-if-equal 34 scm_equal_p)
608
609
610
611 (define-syntax-rule (br_arithmetic nm n cmp-op C)
612   (define-vm-inst nm n ((U8_U12_U12 x y) 
613                         (X8_L24  offset)
614                         (Label label offset))
615   (inst mov call-1 (local-ref x))
616   (inst mov call-2 (local-ref y))
617   (inst test call-1 2)
618   (inst jmp #:z C:)
619   (inst test call-2 2)
620   (inst jmp #:z C:)
621   (inst cmp call-1 call-2)
622   (inst jmp (succ cmp-op) out:)
623  go:
624   (if (< offset 0) (handle-interupts reg1))
625   (inst jmp label)
626  C:
627   (c-call C)
628   (inst cmp reg1 SCM_BOOL_F)
629   (inst jmp #:ne go:)
630  out:))
631
632 (br_arithmetic br-if-=  35 #:eq  scm_num_eq_p)
633 (br_arithmetic br-if-<  36 #:l   scm_less_p)
634 (br_arithmetic br-if-<= 37 #:le  scm_leq_p)
635 (br_arithmetic br-if->  38 #:g   scm_gr_p)
636 (br_arithmetic br-if->= 39 #:ge  scm_geq_p)
637
638
639 (define-vm-inst mov 40 ((U8_U12_U12 from to))
640   (inst mov reg1 (local-ref from))
641   (inst mov (local-ref to) reg1))
642
643 (define-vm-inst long-mov 41 ((U8_U24 from) (X8_U24 to))
644   (inst mov reg1 (local-ref from))
645   (inst mov (local-ref to) reg1))
646
647 (define-vm-inst box 42 ((U8_U12_U12 to from))
648   (inst mov call-1 tc7_variable)
649   (inst mov call-2 (local-ref from))
650   (c-call scm_cell)
651   (inst mov (local-ref to) reg1))
652
653
654 (define-vm-inst empty-box 43 ((U8_U24 to))
655   (inst mov call-1 tc7_variable)
656   (inst mov call-2 SCM_UNDEFINED)
657   (c-call scm_cell)
658   (inst mov (local-ref to) reg1))
659
660 (define-vm-inst box-ref 44 ((U8_U12_U12 to from))
661   (inst mov reg1 (local-ref from))
662   (VARIABLE? reg1 reg2 abort-fkn:)
663   (inst mov reg1 (Q reg1 1))
664   (inst cmp reg1 SCM_UNDEFINED)
665   (inst jmp #:ne boundp:)
666   (inst mov call-1 reg1)
667   (inst mov call-2 (program-ref rbp))
668   (c-call g_box_not_bounded)
669  abort-fkn:
670   (c-call g_abort)
671  boundp:
672   (inst mov (local-ref to) reg1))
673
674 (define-vm-inst box-set! 45 ((U8_U12_U12 to from))
675   (inst mov reg1 (local-ref to))
676   (VARIABLE? reg1 reg2 abort-fkn:)
677   (inst mov reg2 (local-ref from))
678   (inst mov (Q reg1 1) reg2)
679   (inst jmp out:)
680  abort-fkn:
681   (c-call g_abort)
682  out:)
683
684
685
686 (define-vm-inst free-ref 46 ((U8_U12_U12 to from))
687   (inst mov reg1 (program-ref rbp))
688   (inst mov reg1 (free-variable-ref reg1 from))
689   (check-free-variable reg1)
690   (inst mov (local-ref to) reg1))
691
692 (define-vm-inst make-closure 47 ((U8_U24 dst) 
693                                  (L32    offset)
694                                  (X8_R24 nfree)
695                                  (IP ip  offset)
696                                  (N      refs nfree))
697   (inst mov call-1 (logior tc7_rtl_program (ash nfree 16)))
698   (inst mov call-2 (+ nfree 2))
699   (c-call scm_words)
700   (for-each (lambda (n i)
701               (assemble ()
702                 (inst mov reg2 (local-ref n))
703                 (inst mov (free-variable-ref reg1 i) reg2)))
704     refs
705     (iota nfree))
706   (inst mov (Q reg1 1) ip)
707   (inst mov (local-ref dst) reg1))
708
709
710 (define-vm-inst fix-closure 48 ((U8_U24 dst) (X8_R24 nfree) (N refs nfree))
711   (inst mov reg1 (local-ref dst))
712   (for-each (lambda (n i)
713               (assemble ()
714                 (inst mov reg2 (local-ref n))
715                 (inst mov (free-variable-ref reg1 i) reg2)))
716      refs
717      (iota nfree)))
718
719
720 (define-vm-inst make-short-immediate 49 ((U8_U8_I16 dst val))
721   (inst mov (local-ref dst) val))
722
723 (define-vm-inst make-long-immediate 50 ((U8_U24 dst) (I32 val))
724   (inst mov (local-ref dst) val))
725
726 (define-vm-inst make-llong-immediate 51 ((U8_U24 dst) (A32 v1) (B32 v2))
727   (let ((val (+ (ash v1 32) v2)))
728     (inst mov reg1 v1)
729     (inst shl reg1 32)
730     (inst add reg1 v2)
731     (inst mov (local-ref dst) reg1)))
732
733
734 (define-vm-inst make-non-immediate 52 ((U8_U24 dst) 
735                                        (N32    offset) 
736                                        (IP ip  offset))
737   (inst mov call-1 ip)
738   (inst test call-1 #b111)
739   (inst jmp #:z out:)
740   (c-call g_non_not_nonimmediate)
741  out:
742   (inst mov (local-ref dst) call-1))
743
744
745
746 (define-vm-inst static-ref 53 ((U8_U24 dst) 
747                                (S32 offset) 
748                                (IP ip offset))
749   (inst mov call-1 ip)
750   (inst test call-1 #b111)
751   (inst jmp #:z out:)
752   (c-call g_not_scm_aligned)
753  out:
754   (inst mov call-1 (Q call-1))
755   (inst mov (local-ref dst) call-1))
756
757 ;; Not tested yet but probably work
758 (define-vm-inst static-set! 54 ((U8_U24 src) 
759                                 (L32 offset) 
760                                 (IP ip offset))
761   (inst mov call-1 ip)
762   (inst test call-1 #b111)
763   (inst jmp #:z out:)
764   (c-call g_not_scm_aligned)
765  out:
766   (inst mov reg1 (local-ref src))
767   (inst mov (Q call-1) reg1))
768
769
770 ;; not tested yet
771 (define-vm-inst link-procedure! 55 ((U8_U24 src) 
772                                     (L32    offset) 
773                                     (IP ip  offset))
774   (inst mov reg1 (local-ref src))
775   (inst mov reg2 ip)
776   (inst mov (Q reg1 1) reg2))
777
778
779 (define-vm-inst resolve 56 ((U8_U8_U8_U8 dst mod sym))
780   (inst mov call-1 (local-ref mod))
781   (inst mov call-2 (local-ref sym))
782   (c-call scm_module_lookup)
783   (inst mov (local-ref dst) reg1))
784
785
786 ;; not tested yet
787 (define-vm-inst resolve-module 57 ((U8_U8_U8_U8 dst name public))
788   (inst mov call-1 (local-ref name))
789   (if (= public 0)
790       (inst call (resolve-module-hook-0 jmp))
791       (inst call (resolve-module-hook-1 jmp)))
792   (inst mov (local-ref dst) reg1))
793
794 (define-jmp-hook resolve-module-hook-0
795   (c-call* scm_resolve_module reg2)
796   (inst ret))
797
798 (define-jmp-hook resolve-module-hook-1
799   (c-call* scm_resolve_module reg2)
800   (inst mov call-1 reg1)
801   (c-call* scm_module_public_interface reg2)
802   (inst ret))
803   
804
805 ;; not tested yet
806 (define-vm-inst vm-define 58 ((U8_U12_U12 sym val))
807   (inst mov call-1 (local-ref sym))
808   (inst mov call-2 (local-ref val))
809   (c-call scm_define))
810
811 ;; not tested yet
812 (define-vm-inst toplevel-ref 59 ((U8_U24 dst) 
813                                  (S32 var-offset) 
814                                  (S32 mod-offset)
815                                  (N32 sym-offset)
816                                  (IP var-loc var-offset)
817                                  (IP mod-loc mod-offset)
818                                  (IP sym-loc sym-offset))
819   (inst mov reg3 var-loc)
820   (inst test reg3 15)
821   (inst jmp #:nz abort:)
822   (inst mov call-1 (Q reg3))
823   (VARIABLE?-NEG call-1 reg1 out:)
824  nonvar:
825   (inst mov call-2 mod-loc)
826   (inst mov call-3 sym-loc)
827   (c-call g_toplevel_resolve)
828   (inst jmp out:)
829  abort:
830   (c-call g_not_scm_aligned)
831  out:
832   (inst mov (Q reg3) reg1)
833   (inst mov reg1 (Q reg1 1))
834   (inst mov (local-ref dst) reg1))
835
836
837 ;; not tested yet
838 (define-vm-inst module-ref 60 ((U8_U24 dst) 
839                                (S32 var-offset) 
840                                (N32 mon-offset)
841                                (N32 sym-offset)
842                                (IP var-loc var-offset)
843                                (IP mod-loc mon-offset)
844                                (IP sym-loc sym-offset))
845   (inst mov reg3 var-loc)
846   (inst test reg3 15)
847   (inst jmp #:nz abort:)
848   (inst mov call-1 (Q reg3))
849   (VARIABLE?-NEG call-1 reg1 out:)
850  nonvar:
851   (inst mov call-2 mod-loc)
852   (inst mov call-3 sym-loc)
853   (c-call g_moduleref_resolve)
854   (inst jmp out:)
855  abort:
856   (c-call g_not_scm_aligned)
857  out:
858   (inst mov (Q reg3) reg1)
859   (inst mov reg1 (Q reg1 1))
860   (inst mov (local-ref dst) reg1))
861
862
863
864 #;
865 (define-vm-inst vm-prompt 61 ((U8_U24 tag) (U32 return_loc) (U8_L24 escape-only-p offset) (IP ip offset))
866   (inst mov reg1 (cur_th))
867   (inst lea call-1 (Q reg1 th->dynstack))
868   (inst mov call-2 (if escape-only-p SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY 0))
869   (inst mov call-3 (local-ref tag))
870   (inst mov call-4 (vm-sp))
871   (inst mov call-5 ip)
872   (inst lea call-6 (vm-registers))
873   (c-call scm_dynstack_push_prompt))
874
875 ;; not tested yet
876 (define-vm-inst wind 62 ((U8_U12_U12 winder unwinder))
877   (inst mov reg1 (cur_th))
878   (inst lea call-1 (Q reg1 th->dynstack))
879   (inst mov call-2 (local-ref winder))
880   (inst mov call-3 (local-ref unwinder))
881   (c-call scm_dynstack_push_dynwind))
882
883
884 #;
885 (define-vm-inst abort 63 ((U8_U24 tag) (X8_R24 nvalues) (N nvalues refs))
886   (for-each (lambda (x) (assemble () (inst push x))) (reverse refs))
887   (inst mov call-1 (the-vm))
888   (inst mov call-2 (local-ref tag))
889   (inst mov call-3 rsp)
890   (inst mov call-4 (vm-registers))
891   (c-call vm_abort))
892
893 ;; not tested yet
894 (define-vm-inst unwind 64 ((U8_X24))
895   (inst mov reg1 (cur_th))
896   (inst lea call-1 (Q reg1 th->dynstack))
897   (c-call scm_dynstack_pop))
898
899
900 ;; not tested yet
901 (define-vm-inst wind-fluids 65 ((U8_U24 fluid_base) (X8_R24 n) (N refs n))
902   (inst mov reg1 (cur_th))
903   (inst lea call-1 (Q reg1 th->dynstack))
904   (inst mov call-2 n)
905   (inst lea call-3 (Q rbp fluid_base))
906   (inst mov call-4 rbp)
907   (for-each (lambda (x) (assemble () (inst push x))) (reverse refs))  
908   (inst mov call-5 rsp)
909   (inst mov call-6 (Q reg1 th->dynamic_state))
910   (c-call scm_dynstack_push_fluids_shuffled))
911
912 ;; not tested yet
913 (define-vm-inst unwind-fluids 66 ((U8_X24))
914   (inst mov reg1 (cur_th))
915   (inst lea call-1 (Q reg1 th->dynstack))
916   (inst mov call-2 (Q reg1 th->dynamic_state))
917   (c-call scm_dynstack_unwind_fluids))
918
919
920 (define-vm-inst fluid-ref 67 ((U8_U12_U12 dst src))
921   (inst mov call-1 (local-ref src))
922   (inst mov call-2 (cur_th))
923   (c-call g_fluid_ref)
924   (inst mov (local-ref dst) reg1))
925
926 (define-vm-inst fluid-set 68 ((U8_U12_U12 a b))
927   (inst mov call-1 (local-ref a))
928   (inst mov call-2 (local-ref b))
929   (inst mov call-3 (cur_th))
930   (c-call g_fluid_set))
931
932
933 (define-vm-inst string-length 69 ((U8_U12_U12 dst src))
934   (inst mov call-1 (local-ref src))
935   (c-call g_string_length)
936   (inst mov (local-ref dst) reg1))
937
938 (define-vm-inst string-ref 70 ((U8_U8_U8_U8 dst src n))
939   (inst mov call-1 (local-ref src))
940   (inst mov call-2 (local-ref n))
941   (c-call g_string_ref)
942   (inst mov (local-ref dst) reg1))
943
944 (define-vm-inst string->number 71 ((U8_U12_U12 dst src))
945   (inst mov call-1 (local-ref src))
946   (inst mov call-2 SCM_UNDEFINED)
947   (c-call scm_string_to_number)
948   (inst mov (local-ref dst) reg1))
949
950
951
952 (define-vm-inst string->symbol 72 ((U8_U12_U12 dst src))
953   (inst mov call-1 (local-ref src))
954   (c-call scm_string_to_symbol)
955   (inst mov (local-ref dst) reg1))
956
957 (define-vm-inst symbol->keyword 73 ((U8_U12_U12 dst src))
958   (inst mov call-1 (local-ref src))
959   (c-call scm_symbol_to_keyword)
960   (inst mov (local-ref dst) reg1))
961
962
963
964 (define-vm-inst vm-cons 74 ((U8_U8_U8_U8 dst x y))
965   (inst mov call-1 (local-ref x))
966   (inst mov call-2 (local-ref y))
967   (c-call scm_cons)
968   (inst mov (local-ref dst) reg1))
969   
970 (define-vm-inst vm-car 75 ((U8_U12_U12 dst src))
971   (inst mov reg1 (local-ref src))
972   (inst test reg1 7)
973   (inst jmp #:nz car-error:)
974   (inst mov reg1 (Q reg1))
975   (inst test reg1 1)
976   (inst jmp #:nz car-error:)
977   (inst mov (local-ref src) reg1)
978   (inst jmp out:)
979  car-error:
980   (c-call scm_car_error)
981  out:)
982
983 (define-vm-inst vm-cdr 76 ((U8_U12_U12 dst src))
984   (inst mov reg1 (local-ref src))
985   (inst test reg1 7)
986   (inst jmp #:nz cdr-error:)
987   (inst mov reg2 (Q reg1 0))
988   (inst test reg2 1)
989   (inst jmp #:nz cdr-error:)
990   (inst mov reg1 (Q reg1 1))
991   (inst mov (local-ref src) reg1)
992   (inst jmp out:)
993  cdr-error:
994   (c-call scm_cdr_error)
995  out:)
996
997 (define-vm-inst vm-set-car 77 ((U8_U12_U12 src val))
998   (inst mov reg1 (local-ref src))
999   (inst mov reg2 (local-ref val))
1000   (inst test reg1 7)
1001   (inst jmp #:nz car-error:)
1002   (inst mov reg3 (Q reg1))
1003   (inst test reg3 1)
1004   (inst jmp #:nz car-error:)
1005   (inst mov (Q reg1) reg2 )
1006   (inst jmp out:)
1007  car-error:
1008   (c-call scm_setcar_error)
1009  out:)
1010
1011
1012
1013 (define-vm-inst vm-set-cdr 78 ((U8_U12_U12 src val))
1014   (inst mov reg1 (local-ref src))
1015   (inst mov reg2 (local-ref val))
1016   (inst test reg1 7)
1017   (inst jmp #:nz car-error:)
1018   (inst mov reg3 (Q reg1))
1019   (inst test reg3 1)
1020   (inst jmp #:nz car-error:)
1021   (inst mov (Q reg1 1) reg2)
1022   (inst jmp out:)
1023  car-error:
1024   (c-call scm_setcdr_error)
1025  out:)
1026
1027 (define-vm-inst vm-add 79 ((U8_U8_U8_U8 dst x y))
1028   (inst mov call-1 (local-ref x))
1029   (inst mov call-2 (local-ref y))
1030   (inst test call-1 2)
1031   (inst jmp #:z slow:)
1032   (inst test call-2 2)
1033   (inst jmp #:z slow:)
1034   (inst add call-2 call-1)
1035   (inst jmp #:o slow:)
1036   (inst sub call-2 2)
1037   (inst mov (local-ref dst) call-2)
1038   (inst jmp out:)
1039  slow:
1040   (inst mov call-1 (local-ref x))
1041   (inst mov call-2 (local-ref y))
1042   (c-call scm_sum)
1043   (inst mov (local-ref dst) rax)
1044  out:)
1045
1046
1047
1048 (define-vm-inst vm-add1 80 ((U8_U12_U12 dst x))
1049   (inst mov reg1 (local-ref x))
1050   (inst test reg1 2)
1051   (inst jmp #:z slow:)
1052   (inst add reg1 4)
1053   (inst jmp #:o slow:)
1054   (inst jmp out:)
1055  slow:
1056   (inst mov call-1 (local-ref x))
1057   (inst mov call-2 6)
1058   (c-call scm_sum call-1 call-2)
1059  out:
1060   (inst mov (local-ref dst) reg1))
1061
1062 (define-vm-inst vm-sub 81 ((U8_U8_U8_U8 dst x y))
1063   (inst mov call-1 (local-ref x))
1064   (inst mov call-2 (local-ref y))
1065   (inst test call-1 2)
1066   (inst jmp #:z slow:)
1067   (inst test call-2 2)
1068   (inst jmp #:z slow:)
1069   (inst sub call-1 call-2)
1070   (inst jmp #:o slow:)
1071   (inst add call-1 2)
1072   (inst mov (local-ref dst) call-1)
1073   (inst jmp out:)
1074  slow:
1075   (inst mov call-1 (local-ref x))
1076   (c-call scm_difference call-1 call-2)
1077   (inst mov (local-ref dst) rax)
1078  out:)
1079
1080 (define-vm-inst vm-sub1 82 ((U8_U12_U12 dst x))
1081   (inst mov reg1 (local-ref x))
1082   (inst test reg1 2)
1083   (inst jmp #:z slow:)
1084   (inst sub reg1 4)
1085   (inst jmp #:o slow:)
1086   (inst jmp out:)
1087  slow:
1088   (inst mov call-1 (local-ref x))
1089   (inst mov call-2 6)
1090   (c-call scm_difference)
1091  out:
1092   (inst mov (local-ref dst) reg1))
1093
1094
1095
1096 (define-syntax-rule (mk-binary nm n C)
1097   (define-vm-inst nm n ((U8_U8_U8_U8 dst x y))
1098     (inst mov call-1 (local-ref x))
1099     (inst mov call-2 (local-ref y))
1100     (c-call C)
1101     (inst mov (local-ref dst) reg1)))
1102
1103 (mk-binary vm-mul 83 scm_product)
1104 (mk-binary vm-div 84 scm_divide)
1105 (mk-binary vm-quo 85 scm_quotient)
1106 (mk-binary vm-rem 86 scm_remainder)
1107 (mk-binary vm-mod 87 scm_modulo)
1108
1109
1110
1111 (define-vm-inst vm-ash 88 ((U8_U8_U8_U8 dst x y))
1112   (inst mov  rsi (local-ref y))
1113   (inst mov  rdi (local-ref x))
1114   (inst test dil 2)
1115   (inst jmp  #:z slow:)
1116   (inst test sil 2)
1117   (inst jmp  #:z slow:)
1118   (inst sar  rsi 2)
1119   (inst test rsi rsi)
1120   (inst jmp  #:s neg:)
1121   (inst cmp  rsi 60)
1122   (inst jmp  #:a slow:)
1123   (inst sar  rdi 2)
1124   (inst mov  ecx 61)
1125   (inst sub  ecx esi)
1126   (inst mov  rdx rdi)
1127   (inst sar  rdx #:cl)
1128   (inst add  rdx 1)
1129   (inst cmp  rdx 1)
1130   (inst jmp  #:a slow:)
1131   (inst mov  ecx esi)
1132   (inst sal  rdi #:cl)
1133   (inst jmp last:)
1134  slow:
1135   (inst mov call-2 (local-ref y))
1136   (inst mov call-1 (local-ref x))
1137   (c-call scm_ash)
1138   (inst jmp  final:)
1139  neg:
1140   (inst mov  ecx esi)
1141   (inst sar  rdi 2)
1142   (inst neg  ecx)
1143   (inst sar  rdi #:cl)
1144  last:
1145   (inst lea  rax (make-ea #:qword #:disp 2 #:index rdi #:scale 4)) ;;rax <- 4*rdi + 2
1146  final:
1147   (inst mov (local-ref dst) rax))
1148
1149
1150 (define-syntax-rule (mk-logic nm n and C)
1151   (define-vm-inst nm n ((U8_U8_U8_U8 dst x y))
1152     (inst mov call-2 (local-ref y))
1153     (inst mov call-1 (local-ref x))
1154     (inst test call-1 2)
1155     (inst jmp #:z slow:)
1156     (inst test call-2 2)
1157     (inst jmp #:z slow:)
1158     (inst and call-2 call-1)
1159     (inst mov (local-ref dst) call-2)
1160     (inst jmp out:)
1161    slow:
1162     (c-call C)
1163     (inst mov (local-ref dst) rax)
1164    out:))
1165
1166 (mk-logic vm-logand 89 and scm_logand)
1167 (mk-logic vm-logior 90 or  scm_logior)
1168
1169 (define-vm-inst vm-logxor 91 ((U8_U8_U8_U8 dst x y))
1170     (inst mov call-2 (local-ref y))
1171     (inst mov call-1 (local-ref x))
1172     (inst test call-1 2)
1173     (inst jmp #:z slow:)
1174     (inst test call-2 2)
1175     (inst jmp #:z slow:)
1176     (inst xor call-2 call-1)
1177     (inst add call-2 2)
1178     (inst mov (local-ref dst) call-2)
1179     (inst jmp out:)
1180    slow:
1181     (c-call scm_logxor)
1182     (inst mov (local-ref dst) rax)
1183    out:)
1184
1185
1186 (define-vm-inst vector-length 92 ((U8_U12_U12 dst src))
1187   (inst mov call-1 (local-ref src))
1188   (VECTOR? call-1 reg1 reg2 nonvector:)
1189   (inst shr reg1 8)
1190   (inum reg1)
1191   (inst jmp out:)
1192  nonvector:
1193   (c-call scm_vector_length)
1194  out:
1195   (inst mov (local-ref dst) reg1))
1196
1197
1198 (define-vm-inst vm-vector-ref 93 ((U8_U8_U8_U8 dst ar i))
1199   (inst mov call-1 (local-ref ar))
1200   (inst mov call-2 (local-ref i))
1201   (NONWEAK-VECTOR? call-1 reg3 reg2  error:)
1202   (inst test call-2 2)
1203   (inst jmp #:z error:)
1204   (inst mov reg2 call-2)
1205   (inst sar reg2 2)
1206   (inst cmp reg2 0)
1207   (inst jmp #:l  error:)
1208   (inst shr reg3 8)
1209   (inst cmp reg3 reg2)
1210   (inst jmp #:le error:)
1211   (inst mov reg1 (Q call-1 1 reg2 8))
1212   (inst jmp out:)
1213  error:
1214   (c-call scm_vector_ref)
1215  out:
1216   (inst mov (local-ref dst) reg1))
1217
1218
1219
1220 (define-vm-inst constant-vector-ref 94 ((U8_U8_U8_U8 dst ar i))
1221   (inst mov call-1 (local-ref ar))
1222   (inst mov call-2 i)
1223   (NONWEAK-VECTOR? call-1 reg3 reg2 error:)
1224   (inst shr reg3 8)
1225   (inst cmp reg3 call-2)
1226   (inst jmp #:le error:)
1227   (inst mov reg1 (Q call-1 1 call-2 8))
1228   (inst jmp out:)
1229  error:
1230   (inum call-2)
1231   (c-call scm_vector_ref)
1232  out:
1233   (inst mov (local-ref dst) reg1))
1234
1235
1236 (define-vm-inst vm-vector-set! 95 ((U8_U8_U8_U8 ar i v))
1237   (inst mov call-1 (local-ref ar))
1238   (inst mov call-2 (local-ref i))
1239   (inst mov call-3 (local-ref v))
1240   (NONWEAK-VECTOR? call-1 reg3 reg2 error:)
1241   (inst test call-2 2)
1242   (inst jmp #:z error:)
1243   (inst mov reg2 call-2)
1244   (inst sar reg2 2)
1245   (inst cmp reg2 0)
1246   (inst jmp #:l  error:)
1247   (inst shr reg3 8)
1248   (inst cmp reg3 reg2)
1249   (inst jmp #:le error:)
1250   (inst mov (Q call-1 1 reg2 8) call-3)
1251   (inst jmp out:)
1252  error:
1253   (c-call scm_vector_set_x)
1254  out:)
1255
1256
1257   
1258 (define-vm-inst struct-vtable 96 ((U8_U12_U12 dst src))
1259   (inst mov call-1 (local-ref src))
1260   (STRUCT? call-1 reg2 reg3 error:)
1261   (inst sub reg2 tc3_struct)
1262   (inst mov reg1 (Q reg2 2))
1263   (inst jmp out:)
1264  error:
1265   (c-call g_struct_error)
1266  out:
1267   (inst mov (local-ref dst) reg1))
1268
1269
1270 (define-vm-inst make-struct 97 ((U8_U12_U12 dst vtable_r) 
1271                                 (X8_R24     n_init) 
1272                                 (N  vec     n_init))
1273   (for-each
1274    (lambda (x) 
1275      (assemble ()
1276         (inst mov reg1 (local-ref x))
1277         (inst push reg1)))
1278    (reverse vec))
1279   (inst mov call-1 (local-ref vtable_r))
1280   (inst mov call-2 rsp)
1281   (inst mov call-3 n_init)
1282   (c-call g_make_struct)
1283   (inst lea rsp (Q rsp n_init))
1284   (inst mov (local-ref dst) reg1))
1285
1286 ;; This is too complicated, probably a direct call is not too much overhead
1287 #;
1288 (define-vm-inst struct-ref 98 ((U8_U8_U8_U8 dst src n))
1289   (inst mov call-1 (local-ref src))
1290   (inst mov call-2 (local-ref n))
1291   (STRUCT? call-1 reg1 reg2 error:)
1292   (inst sub reg1 tc3_struct)
1293   (inst mov reg2 (Q reg1 1))
1294   (inst test reg2 #b100000)
1295   (inst jmp #:z error:)
1296   (inst test call-2 2)
1297   (inst jmp #:z error:)
1298   (inst mov reg2 call-2)  
1299   (inst sar reg2 2)
1300   (inst mov reg3 (Q reg1 2))
1301   (inst mov reg3 (Q reg3))
1302   (inst sub reg3 tc3_struct)
1303   (inst mov reg3 (Q reg3 6))
1304   (inst cmp reg2 reg3)
1305   (inst jmp #:ge error:)
1306   (inst mov reg1 (Q reg1 1 reg2 8))
1307   (inst jmp out:)
1308  error:
1309   (c-call scm_struct_ref)
1310  out:
1311   (inst mov (local-ref dst) reg1))
1312
1313 (define-vm-inst struct-ref 98 ((U8_U8_U8_U8 dst src n))
1314   (inst mov call-1 (local-ref src))
1315   (inst mov call-2 (local-ref n))
1316   (c-call scm_struct_ref)
1317   (inst mov (local-ref dst) reg1))
1318
1319
1320 ;; This is also too complex and it is probably wrong
1321 #;
1322 (define-vm-inst struct-set! 99 ((U8_U8_U8_U8 dst n src))
1323   (inst mov call-1 (local-ref src))
1324   (inst mov call-2 (local-ref n))
1325   (STRUCT? call-1 reg1 reg2 error:)
1326   (inst sub reg1 tc3_struct)
1327   (inst mov reg2 (Q reg1 1))
1328   (inst test reg2 #b100000)
1329   (inst jmp #:z error:)
1330   (inst test call-2 2)
1331   (inst jmp #:z error:)
1332   (inst mov reg2 call-2)  
1333   (inst sar reg2 4)
1334   (inst mov reg3 (Q reg1 2))
1335   (inst mov reg3 (Q reg3))
1336   (inst sub reg3 tc3_struct)
1337   (inst mov reg3 (Q reg3 6))
1338   (inst cmp reg2 reg3)
1339   (inst jmp #:ge error:)
1340   (inst mov (Q reg1 1 reg2 8) call-3)
1341   (inst jmp out:)
1342  error:
1343   (c-call scm_struct_set_x)
1344  out:
1345   (inst mov (local-ref dst) reg1))
1346
1347 (define-vm-inst struct-set! 99 ((U8_U8_U8_U8 dst n src))
1348   (inst mov call-1 (local-ref dst))
1349   (inst mov call-2 (local-ref n))
1350   (inst mov call-3 (local-ref src))
1351   (c-call scm_struct_set_x))
1352
1353
1354 (define-vm-inst class-of 100 ((U8_U12_U12 dst src))
1355   (inst mov call-1 (local-ref src))
1356   (STRUCT? call-1 reg2 reg3 error:)
1357   (inst sub reg2 tc3_struct)
1358   (inst mov reg1 (Q reg2 2))
1359   (inst jmp out:)
1360  error:
1361   (c-call scm_class_of)
1362  out:
1363   (inst mov (local-ref dst) reg1))
1364
1365
1366 (define-vm-inst slot-ref 101 ((U8_U8_U8_U8 dst src idx))
1367   (inst mov reg1 (local-ref src))
1368   (inst mov reg1 (Q reg1 (+ 1 idx)))
1369   (inst mov (local-ref dst) reg1))
1370
1371 (define-vm-inst slot-set 102 ((U8_U8_U8_U8 dst idx src))
1372   (inst mov reg1 (local-ref dst))
1373   (inst mov reg2 (local-ref src))
1374   (inst mov (Q reg1 (+ 1 idx)) reg2))
1375
1376 ;; Not tested yet
1377 (define-vm-inst load-typed-array 103 ((U8_U8_U8_U8 dst type shape)
1378                                       (N32 offset)
1379                                       (U32 len)
1380                                       (IP ip offset))
1381   (inst mov call-1 (local-ref type))
1382   (inst mov call-2 (local-ref shape))
1383   (inst mov call-3 ip)
1384   (inst mov call-4 len)
1385   (c-call scm_from_contiguous_typed_array)
1386   (inst mov (local-ref dst) reg1))
1387
1388
1389 ;; Not tested yet
1390 (define-vm-inst make-array 104 ((U8_U12_U12 dst type)
1391                                 (X8_U12_U12 fill bounds))
1392   (inst mov call-1 (local-ref type))
1393   (inst mov call-2 (local-ref fill))
1394   (inst mov call-3 (local-ref bounds))
1395   (c-call scm_make_typed_array)
1396   (inst mov (local-ref dst) reg1))
1397
1398
1399
1400 (define-syntax-rule (bv-fixable-int-ref nm n C . l)
1401   (define-vm-inst nm n ((U8_U8_U8_U8 dst bv idx))
1402     (inst mov call-1 (local-ref bv))
1403     (inst mov call-2 (local-ref idx))
1404     (c-call C)
1405     (inst mov (local-ref dst) reg1)))
1406
1407
1408 (define-syntax-rule (bv-int-ref nm n C . l)
1409   (define-vm-inst nm n ((U8_U8_U8_U8 dst bv idx))
1410     (inst mov call-1 (local-ref bv))
1411     (inst mov call-2 (local-ref idx))
1412     (c-call C)
1413     (inst mov (local-ref dst) reg1)))
1414
1415 (define-syntax-rule (bv-float-ref nm n C . l)
1416   (define-vm-inst nm n ((U8_U8_U8_U8 dst bv idx))
1417     (inst mov call-1 (local-ref bv))
1418     (inst mov call-2 (local-ref idx))
1419     (c-call C)
1420     (inst mov (local-ref dst) reg1)))
1421
1422 (bv-fixable-int-ref bv-u8-ref  105 scm_bytevector_u8_ref)
1423 (bv-fixable-int-ref bv-s8-ref  106 scm_bytevector_s8_ref)
1424 (bv-fixable-int-ref bv-u16-ref 107 scm_bytevector_u16_ref)
1425 (bv-fixable-int-ref bv-s16-ref 108 scm_bytevector_s16_ref)
1426 (bv-fixable-int-ref bv-u32-ref 109 scm_bytevector_u32_ref)
1427 (bv-fixable-int-ref bv-s32-ref 110 scm_bytevector_s32_ref)
1428
1429 (bv-int-ref bv-u64-ref 111 scm_bytevector_u64_native_ref)
1430 (bv-int-ref bv-s64-ref 112 scm_bytevector_s64_native_ref)
1431
1432 (bv-float-ref bv-f32-ref 113 scm_bytevector_f32_native_ref)
1433 (bv-float-ref bv-f64-ref 114 scm_bytevector_f64_native_ref)
1434
1435
1436 (define-syntax-rule (bv-fixable-int-set nm n C . l)
1437   (define-vm-inst nm n ((U8_U8_U8_U8 dst idx src))
1438     (inst mov call-1 (local-ref dst))
1439     (inst mov call-2 (local-ref idx))
1440     (inst mov call-3 (local-ref src))
1441     (c-call C)))
1442
1443 (define-syntax-rule (bv-int-set nm n C . l)
1444   (define-vm-inst nm n ((U8_U8_U8_U8 dst idx src))
1445     (inst mov call-1 (local-ref dst))
1446     (inst mov call-2 (local-ref idx))
1447     (inst mov call-3 (local-ref src))
1448     (c-call C)))
1449
1450 (define-syntax-rule (bv-float-set nm n C . l)
1451   (define-vm-inst nm n ((U8_U8_U8_U8 dst idx src))
1452     (inst mov call-1 (local-ref dst))
1453     (inst mov call-2 (local-ref idx))
1454     (inst mov call-3 (local-ref src))
1455     (c-call C)))
1456
1457 (bv-fixable-int-set bv-u8-set  115 scm_bytevector_u8_set_x)
1458 (bv-fixable-int-set bv-s8-set  116 scm_bytevector_s8_set_x)
1459 (bv-fixable-int-set bv-u16-set 117 scm_bytevector_u16_set_x)
1460 (bv-fixable-int-set bv-s16-set 118 scm_bytevector_s16_set_x)
1461 (bv-fixable-int-set bv-u32-set 119 scm_bytevector_u32_set_x)
1462 (bv-fixable-int-set bv-s32-set 120 scm_bytevector_s32_set_x)
1463
1464 (bv-int-ref vm-u64-set 121 scm_bytevector_u64_native_set_x)
1465 (bv-int-ref vm-s64-set 122 scm_bytevector_s64_native_set_x)
1466
1467 (bv-float-ref vm-f32-set 123 scm_bytevector_f32_native_set_x scm_from_float
1468             4 D 3 void)
1469 (bv-float-ref vm-f64-set 124 scm_bytevector_f64_native_set_x scm_from_double
1470             8 Q 7 void)
1471
1472 (define-vm-inst vm-asm 125 ((U8_U24 i-asm))
1473   (eject-asm i-asm))