fixed a simple argument order bug in ash native compilation
[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 vm)
5   #:use-module (native vm program)
6   #:use-module (native vm c-callers)
7   #:use-module (native vm c-call)
8   #:use-module (native aschm)
9   #:use-module (native vm constants))
10
11 (define-syntax-rule (return-block code ...)
12   (assemble ()
13     (inst mov reg1 (&& cont:))
14     (inst mov (ret) reg1)
15     code ...
16   cont:))
17
18 (define-vm-inst nop  0 ()
19   (inst nop))
20
21 #;
22 (define-vm-inst halt 1 ()
23   (jump-to-inst 1))
24
25 (define-vm-inst drop 2 ()
26   (inst pop reg1))
27
28 (define-vm-inst dup  3 ()
29   (inst push (Q rsp 0)))
30
31 (define-vm-inst void 4 ()
32   (inst push SCM_UNSPECIFIED))
33
34 (define-vm-inst make-true 5 ()
35   (inst push SCM_BOOL_T))
36
37 (define-vm-inst make-false 6 ()
38   (inst push SCM_BOOL_F))
39
40 (define-vm-inst make-nil 7 ()
41   (inst push SCM_ELISP_NIL))
42
43 (define-vm-inst make-eol 8 ()
44   (inst push SCM_EOL))
45
46 (define-vm-inst make-int8 9 (arg)
47   (inst push (make+-inum arg)))
48
49 (define-vm-inst make-int8:0 10 ()
50   (inst push SCM_INUM0))
51
52 (define-vm-inst make-int8:1 11 ()
53   (inst push SCM_INUM1))
54
55 (define-vm-inst make-int16 12 (a1 a2)
56   (inst push (make+-inum a1 a2)))
57
58 (define-vm-inst make-int64 13 (a1 a2 a3 a4 a5 a6 a7 a8)
59   (inst mov rax (make+-inum a1 a2 a3 a4 a5 a6 a7 a8))
60   (inst push rax))
61
62 (define-vm-inst make-uint64 14 (a1 a2 a3 a4 a5 a6 a7 a8)
63   (inst mov rax (make+inum a1 a2 a3 a4 a5 a6 a7 a8))
64   (inst push rax))
65
66
67
68 #;
69 (define-vm-inst make-char8 15 (a1)
70   (inst push (make-char a1)))
71
72 #;
73 (define-vm-inst make-char32 16 (a1 a2 a3 a4)
74   (inst push (make-char a1 a2 a3 a4)))
75
76 (define-vm-inst make-list 17 (a1 a2)
77   (return-block
78    (inst mov reg2 (make+num a1 a2))
79    (inst jmp (make-list-jmp jmp))))
80
81
82 (define-jmp-hook make-list-jmp
83   (inst mov call-2 SCM_EOL)
84  loop:
85   (inst cmp reg2 0)
86   (inst jmp #:eq out:)
87   (inst pop call-1)  
88   (c-call scm_cons call-1 call-2)
89   (inst mov call-2 reg1)
90   (inst dec reg2)
91   (inst jmp loop:)
92  out:
93   (inst push call-2)
94   (inst jmp (ret))
95   )
96
97
98
99
100 (define-vm-inst make-vector 18 (a1 a2)
101   (inst mov call-1 (make+num a1 a2))
102   (inst mov call-2 rsp)
103   (c-call scm_vector call-1 call-2)  
104   (inst lea rsp (Q rsp (make+num a1 a2)))
105   (inst push rax))
106
107
108 (define-vm-inst object-ref 19 (a1)
109   (get-object a1 reg1)
110   (inst push reg1))
111
112 (define-vm-inst long-object-ref 20 (a1 a2)
113   (get-object (make+num a1 a2) reg1)
114   (inst push reg1))
115
116 (define-vm-inst local-ref 21 (a1)
117   (inst push (get-local a1)))
118
119 (define-vm-inst long-local-ref 22 (a1 a2)
120   (inst push (get-local (make+num a1 a2))))
121
122
123 (define-vm-inst local-bound 23 (a1)
124   (bound a1))
125
126 (define-vm-inst long-local-bound 24 (a1 a2)
127   (bound (make+num a1 a2)))
128
129 (define (bound a1)
130   (assemble ()
131      (inst mov reg1 (get-local a1))
132      (inst mov reg2 SCM_BOOL_F)
133      (inst cmp reg1 SCM_UNDEFINED)
134      (inst jmp #:eq out:)
135      (inst mov reg2 SCM_BOOL_T)
136     out:
137      (inst push reg2)))
138
139
140 #;
141 (define-vm-inst variable-ref 25 ()
142   (mv reg1 (sp 0))
143   (SCM_VARIABLE? reg1 no-varable)
144   (SCM_VARIABLE_BOUND? reg1 not-bounded)
145   (inst mov reg2 (VARIABLE_REF reg1))
146   (mv (sp 0) reg2))
147
148 #;
149 (define-vm-inst variable-bound? 26 ())
150
151 #;
152 (define-vm-inst toplevel-ref 27 (a1)
153   (let ((o (resolve (object-ref a1))))
154     (inst mov reg1 (id o))
155     (push (Q reg 1))))
156
157 #;
158 (define-vm-inst long-toplevel-ref 28 (a1 a2)
159   (let ((o (resolve (object-ref (make+num a1 a2)))))
160     (inst mov reg1 (id o))
161     (push (VARIABLE-REF reg1))))
162           
163 (define-vm-inst local-set 29 (a1)
164   (inst pop  reg1)
165   (inst mov  (get-local a1) reg1))
166
167 (define-vm-inst long-local-set 30 (a1 a2)
168   (inst pop  reg1)
169   (inst mov  (get-local (make+num a1 a2)) reg1))
170
171 #;
172 (define-vm-inst variable-set 31 ()
173   (inst pop reg1)
174   (inst pop reg2)
175   (VARIABLE? reg1 no-varable-set)
176   (inst mov (VARIABLE_REF reg1) reg2))
177 #;
178 (define-vm-inst toplevel-set 32 (a1)
179   (topset a1))
180
181 #;
182 (define-vm-inst long-toplevel-set 33 (a1 a2)
183   (topset (make+num a1 a2)))
184 #;
185   (define (topset x)
186   (let ((o (get-var-object x)))
187     (assemble ()
188       (inst mov reg1 o)
189       (inst pop reg2)
190       (inst mov (VARIABLE_REF o) reg2))))
191   
192 (define-syntax-rule (define-jumper nm id code ... (BR pred))
193   (define-vm-inst-jmp nm id (x y z) (label (bit-offset x y z))
194     code ...        
195     (let ((d     (bit-offset x y z)))
196       (if (< d 0)
197           (begin
198             (handle-interupts)
199             (inst jmp pred label))
200           (inst jmp pred label)))))
201
202 (define (handle-interupts) 'not-implemented)
203
204 (define-vm-inst-jmp br 34 (a b c) (label (bit-offset a b c))
205   (let* ((d (bit-offset a b c)))    
206     (if (< d 0)
207         (begin
208           (handle-interupts)
209           (inst jmp label))
210         (inst jmp label))))
211
212
213 (define-jumper br-if 35 
214   (inst pop reg1)
215   (inst cmp reg1 SCM_BOOL_F)
216   (BR #:ne))
217
218 (define-jumper br-if-not 36
219   (inst pop reg1)
220   (inst cmp reg1 SCM_BOOL_F)
221   (BR #:eq))
222
223
224 (define-jumper br-if-eq 37
225   (inst pop reg1)
226   (inst pop reg2)
227   (inst cmp reg1 reg2)
228   (BR #:eq))
229
230 (define-jumper br-if-not-eq 38
231   (inst pop reg1)
232   (inst pop reg2)
233   (inst cmp reg1 reg2)
234   (BR #:ne))
235
236 (define-jumper br-if-null 39
237   (inst pop reg1)
238   (inst cmp reg1 SCM_EOL)
239   (BR #:eq))
240
241 (define-jumper br-if-not-null 40
242   (inst pop reg1)
243   (inst cmp reg1 SCM_EOL)
244   (BR #:ne))
245
246 #;
247 (define-vm-instr br_if_nargs_ne 41 (a b x y z)
248   (let ((n     (make+num a b))
249         (label (get-label (bit-offset x y z))))
250     (inst mov reg1 sp)
251     (inst sub reg1 bp)
252     (inst cmp reg1 (- n 1))
253     (inst jmp #:neq  label)))
254
255 #;
256 (define-vm-instr br_if_nargs_lt 42 (a b x y z)
257   (let ((n     (make+num a b))
258         (label (get-label (bit-offset x y z))))
259     (inst mov reg1 sp)
260     (inst sub reg1 bp)
261     (inst cmp reg1 (- n 1))
262     (inst jmp #:l  label)))
263
264 #;
265 (define-vm-instr br_if_nargs_gt 43 (a b x y z)
266   (let ((n     (make+num a b))
267         (label (get-label (bit-offset x y z))))
268     (inst mov reg1 sp)
269     (inst sub reg1 bp)
270     (inst cmp reg1 (- n 1))
271     (inst jmp #:g  label)))
272 #;
273 (define-vm-instr br_if_nargs_ee 44 (a b)
274   (let ((n     (make+num a b)))
275     (inst mov reg1 sp)
276     (inst sub reg1 bp)
277     (inst cmp reg1 (- n 1))
278     (inst jmp #:neq  vm_error_wrong_num_args)))
279 #;
280 (define-vm-instr br_if_nargs_ge 45 (a b)
281   (let ((n     (make+num a b)))
282     (inst mov reg1 sp)
283     (inst sub reg1 bp)
284     (inst cmp reg1 (- n 1))
285     (inst jmp #:l  vm_error_wrong_num_args)))
286
287 #;
288 (define-vm-instr bind-optionals 46 (a b)
289   (let ((n     (make+num a b)))
290     (inst mov reg1 bp)
291     (inst add reg1 (- n 1))
292    loop:
293     (inst cmp reg1 sp)
294     (inst jmp #:ge out)
295     (inst push SCM_UNDEFINED)
296     (jmp loop:)
297     out:))
298
299 ;;TODO
300 #;
301 (define-vm-instr bind-optionals-shuffle 47 (a b i j x y)
302   (let ((n     (make+num a b)))
303     (inst mov reg1 bp)
304     (inst add reg1 (- n 1))
305    loop:
306     (inst cmp reg1 sp)
307     (inst jmp #:ge out)
308     (inst push SCM_UNDEFINED)
309     (jmp loop:)
310     out:))
311
312 ;;TODO
313 #;
314 (define-vm-instr bind-lwargs 48 (a b i j x))
315
316 #;
317 (define-vm-instr push-rest 49 (a b i j)
318   (let ((n (make+num a b))
319         (m (make+num i j)))
320     (assemble ()
321       (inst mov call-2 SCM_EOL)
322       (inst mov reg1 bp)
323       (inst add reg1 (- n 1))
324      loop:
325       (inst cmp sp reg1)
326       (inst jmp #:le out:)
327       (inst pop call-1)
328       (c-call scm_cons call-1 call-2)
329       (inst pop call-2)
330       (inst jmp loop:)
331      out:
332       (inst mov (local-ref m) call-2))))
333
334 #;
335 (define-vm-instr bind-rest 50 (a b i j)
336   (let ((n (make+num a b))
337         (m (make+num i j)))
338     
339     (inst mov call-2 SCM_EOL)
340     (inst mov reg1 bp)
341     (inst add reg1 (- n 1))
342    (assemble ()
343      loop:
344       (inst cmp sp reg1)
345       (inst jmp #:le out:)
346       (inst pop call-1)
347       (c-call scm_cons call-1 call-2)
348       (inst pop call-2)
349       (inst jmp loop:)
350      out:
351       (inst push call-2))))
352
353
354 (define-vm-inst reserve-locals 51 (a b)
355   (let ((n (make+num a b)))
356    (assemble ()
357      (inst mov rsp rbp)
358      (inst add rsp (- n 1))
359      #;(nullstack)
360      )))
361
362
363 (define-vm-inst new-frame 52 ()
364   (inst push 0)
365   (inst push 0)
366   (inst push 0))
367
368 ;;TODO make sure that the call stub works here
369 #;  
370 (define-vm-inst call 53 (nargs)
371   (inst mov reg1 (sp (- nargs)))
372   (inst mov ret  (&& next:))
373   (inst jmp (call-program))
374  next:
375  )
376
377
378 ;;TODO make sure that the call stub works here
379 #;  
380 (define-vm-inst tail-call 54 (nargs)
381   (inst mov reg1 (sp (- nargs)))
382   (inst mov ret  (&& next:))
383   (inst jmp (tail-call-program))
384  next:
385  )
386
387 ;;TODO make sure that the call stub works here
388 #;  
389 (define-vm-inst subr-call 55 (nargs)
390   (inst mov reg1 (sp (- nargs)))
391   (inst mov ret  (&& next:))
392   (inst jmp (tail-call-program))
393  next:
394  )
395
396 ;;TODO make sure that the call stub works here
397 #;  
398 (define-vm-inst smob-call 56 (nargs)
399   (inst mov reg1 (sp (- nargs)))
400   (inst mov ret  (&& next:))
401   (inst jmp (tail-call-program))
402  next:
403  )
404
405 ;;TODO make sure that the call stub works here
406 #;  
407 (define-vm-inst foreign-call 57 (nargs)
408   (inst mov reg1 (sp (- nargs)))
409   (inst mov ret  (&& next:))
410   (inst jmp (tail-call-program))
411  next:
412  )
413
414 ;;TODO make sure that the call stub works here
415 #;  
416 (define-vm-inst continuation-call 58 (nargs)
417   (inst mov reg1 (sp (- nargs)))
418   (inst mov ret  (&& next:))
419   (inst jmp (tail-call-program))
420  next:
421 )
422   
423 ;;TODO make sure that the call stub works here
424 #;  
425 (define-vm-inst partial-continuation-call 59 (nargs)
426   (inst mov reg1 (sp (- nargs)))
427   (inst mov ret  (&& next:))
428   (inst jmp (tail-call-program))
429  next:
430 )
431
432 ;;TODO make sure that the call stub works here
433 #;  
434 (define-vm-inst tail-call-nargs 60(nargs)
435   (inst mov reg1 (sp (- nargs)))
436   (inst mov ret  (&& next:))
437   (inst jmp (tail-call-program))
438  next:
439 )
440   
441
442 ;;TODO make sure that the call stub works here
443 #;  
444 (define-vm-inst call/nargs 61(nargs)
445   (inst mov reg1 (sp (- nargs)))
446   (inst mov ret  (&& next:))
447   (inst jmp (tail-call-program))
448  next:
449 )
450   
451
452 ;;TODO make sure that the call stub works here
453 #;  
454 (define-vm-inst mv-call 62(nargs)
455   (inst mov reg1 (sp (- nargs)))
456   (inst mov ret  (&& next:))
457   (inst jmp (tail-call-program))
458  next:
459 )
460
461 ;;TODO make sure that the call stub works here
462 #;  
463 (define-vm-inst apply 63(nargs)
464   (inst mov reg1 (sp (- nargs)))
465   (inst mov ret  (&& next:))
466   (inst jmp (tail-call-program))
467  next:
468 )
469
470 ;;TODO make sure that the call stub works here
471 #;  
472 (define-vm-inst tail-apply 64(nargs)
473   (inst mov reg1 (sp (- nargs)))
474   (inst mov ret  (&& next:))
475   (inst jmp (tail-call-program))
476  next:
477 )
478   
479 ;;TODO make sure that the call stub works here
480 #;  
481 (define-vm-inst call/cc 65 (nargs)
482   (inst mov reg1 (sp (- nargs)))
483   (inst mov ret  (&& next:))
484   (inst jmp (tail-call-program))
485  next:
486 )
487
488 ;;TODO make sure that the call stub works here
489 #;  
490 (define-vm-inst tail-call/cc 66 (nargs)
491   (inst mov reg1 (sp (- nargs)))
492   (inst mov ret  (&& next:))
493   (inst jmp (tail-call-program))
494  next:
495 )
496
497
498
499 (define (lower-addres reg) (Q reg 4))
500 (define (return-ip    reg) (Q reg 2))
501 (define (dynamic-link reg) (Q reg 3))
502
503 (define-vm-inst return 67 ()
504   (inst jmp (return-hook jmp)))
505
506 (define-jmp-hook return-hook
507   #;(pop-continuation-hook 1)
508   #;(handle-interupts)
509   (inst pop reg1)
510   (inst lea rsp  (lower-addres rbp))
511   (inst mov reg2 (return-ip    rbp))
512   (inst mov rbp  (dynamic-link rbp))
513   #;(nullstack)
514   #;(inst mov (program) (bp-program bp))
515   #;(cache-program)
516   (inst mov reg3 (get-program rbp))
517   (inst cmp reg3 0)
518   (inst jmp #:eq skip:)
519   
520   ;; cache object table
521   (inst mov reg4 (OBJTABLE-REF reg3))
522   (inst mov (vm-obj) reg4)
523
524   ;; cache free variables
525   (inst lea reg4 (FREEVAR-REF reg3))
526   (inst mov (vm-clo) reg4)
527
528  skip:
529   (inst push reg1)
530   (inst jmp  reg2))
531
532
533
534
535 #;
536 (define-vm-inst return/values 68 (a)
537   (inst mov reg1 a)
538   (inst jmp (return-values-hook)))
539
540 #;
541 (define-vm-inst return/values* 69 (a)
542   (inst mov reg1 a)
543   (inst jmp (return-values-hook)))
544
545 #;
546 (define-vm-inst return/values* 70 ()
547   (inst pop reg1)
548   (scm-to-int reg1)
549   (inst jmp (return/nvalues-hook)))
550
551 ;; TODO make sure the rest hook works
552
553 #;
554 (define-vm-inst truncate-values 71 (nbinds rest)
555   (inst pop reg1)
556   (scm-to-int reg1)
557   (if (= rest 0)
558       (begin
559         (inst mov reg2 nbinds)
560         (inst cmp reg1 reg2)
561         (inst jmp #:l (vm_error_not_enough_values))
562         (inst sub reg1 reg2)
563         (inst sub sp reg1))
564       (begin
565         (inst mov reg2 rest)
566         (inst mov reg3 nbinds)
567         (inst mov ret  (&& next:))
568         (inst jmp (truncate-values-hook))))
569   next:
570   )
571 #;
572 (define-vm-inst box 72 (a)
573   (inst pop call-2)
574   (inst mov ret (&& cont:))
575   (inst jmp (box-hook))
576  cont:
577   (inst pop reg1)
578   (inst mov (local-ref a) reg1))
579
580 #;
581 (define-jmp-hook box-hook
582   (sync-before-gc)
583   (inst mov call-1 tc7_variable)
584   (c-call scm-cell call-1 call-2)
585   (inst jmp ret))
586
587 #;
588 (define-vm-inst empty-box 73 (a)
589   (inst mov call-2 SCM_EOL)
590   (inst mov ret (&& cont:))
591   (inst jmp (box-hook))
592  cont:
593   (inst pop reg1)
594   (inst mov (local-ref a) reg1))
595
596 #;
597 (define-vm-inst local-boxed-ref 74 (a)
598   (local-box-ref* a))
599
600 #;
601 (define (local-box-ref* a)
602   (inst mov reg1 (local-ref a))
603   (VARIABLE? reg1 abort-hook)
604   (inst mov reg1 (VARIABLE-REF reg1))
605   (inst cmp reg1 SCM_UNDEFINED)
606   (inst jmp #:eq abort-hook)
607   (inst push reg1))
608  
609 #;
610 (define-vm-inst local-boxed-set 75 (a)
611   (inst mov reg1 (local-ref a))
612   (VARIABLE? reg1 abort-hook)
613   (inst pop reg2)
614   (inst mov (VARIABLE-REF reg1) reg2))
615
616 #;
617 (define-vm-inst free-ref 76 (a)
618   (check-free-variable a)
619   (free-variable-ref a reg1)
620   (push reg1))
621
622 #;
623 (define-vm-inst free-boxed-ref 77 (a)
624   (check-free-variable a)
625   (free-variable-ref a reg1)
626   (VARIABLE? reg1 abort-hook)
627   (inst mov reg1 (VARIABLE-REF reg1))
628   (inst cmp reg1 SCM_UNDEFINED)
629   (inst jmp #:eq abort-hook)
630   (push reg1))
631
632 #;
633 (define-vm-inst free-boxed-set 78 (a)
634   (check-free-variable a)
635   (free-variable-ref a reg1)
636   (VARIABLE? reg1 abort-hook)
637   (inst pop reg2)
638   (inst mov (VARIABLE-REF reg1) reg2))
639
640 #;
641 (define-vm-inst make-closure 79 (a b)
642   (inst mov reg1 (make+num a b))
643   (inst mov ret  (&& next:))
644   (inst jmp (make-closure-hook))
645  next:)
646
647 ;;TODO make the closure hook
648
649 #;
650 (define-vm-inst make-closure 80 ()
651   (inst mov ret  (&& next:))
652   (inst jmp (make-closure-hook))
653  next:)
654
655 #;
656 (define-vm-inst fix-closure 81 (a b)
657   (inst mov reg1 (local-ref (make+num a b)))
658   (gosub fix-closure-hook))
659
660 #;
661 (define-hook-inst fix-closure-hook
662   (PROGRAM? reg1 (abort-hook))
663   (inst mov reg2 (PROGRAM_LEN reg1))
664   (inst xor reg3 reg3)
665   (inst mov reg4 ref1)
666   (inst neg reg4)
667   (inst inc reg4)
668  loop:
669   (inst cmp reg3 reg2)
670   (inst jmp #:ge out:)
671   (inst mov (PROGRAM-REF reg1 reg3) (sp reg4))
672   (inst inc reg3)
673   (inst inc reg4)
674   (inst jmp loop:)
675  out:
676   (dropn sp reg2))
677
678 #;
679 (define-vm-inst vm-define 82 ()
680   (gosub-hook define-hook))
681
682 #;
683 (define-vm-inst make-keyword 83 ()
684   (gosub-hook keyword-hook))
685
686 #;
687 (define-vm-inst make-symbol 84 ()
688   (gosub-hook symbol-hook))
689
690 #;
691 (define-vm-inst prompt 85 ()
692   (gosub-hook prompt-hook))
693
694 #;
695 (define-vm-inst wind 86 ()
696   (gosub-hook wind-hook))
697
698 #;
699 (define-vm-inst abort 87 ()
700   (gosub-hook abort-hook))
701
702 #;
703 (define-vm-inst unwind 88 ()
704   (gosub-hook unwind-hook))
705
706 #;
707 (define-vm-inst wind-fluids 89 ()
708   (gosub-hook wind-fluids-hook))
709
710 #;
711 (define-vm-inst unwind-fluids 90 ()
712   (gosub-hook unwind-fluids-hook))
713
714 #;
715 (define-vm-inst fluid-ref 91 ()
716   (gosub-hook fluid-ref-hook))
717
718 #;
719 (define-vm-inst fluid-set 92 ()
720   (gosub-hook fluid-set-hook))
721
722
723 (define-vm-inst assert-nargs-ee/locals 93 (a)
724   (inst mov rax rbp)
725   (inst sub rax rsp)
726   (inst cmp rax (* (logand a 7) 8))  
727   (inst jmp #:eq ok:)
728   (inst mov call-1 rax)
729   (c-call scm_wrong_argument)
730  ok:
731   (inst sub rsp (* (ash a -3) 8)))
732   
733
734
735 ;;.......................................................
736 ;; vm-i-scheme
737 ;;.......................................................
738 (define-vm-inst vm-not 128 ()
739   (inst pop reg1)
740   (inst mov reg2 SCM_BOOL_F)
741   (inst cmp reg1 SCM_BOOL_F)
742   (inst jmp #:neq out:)
743   (inst mov reg2 SCM_BOOL_T)
744  out:
745   (inst push reg2))
746
747
748 (define-vm-inst vm-not-not 129 ()
749   (inst pop reg1)
750   (inst cmp reg1 SCM_BOOL_F)
751   (inst jmp #:eq out:)
752   (inst mov reg1 SCM_BOOL_T)
753  out:
754   (inst push reg1))
755
756 (define-vm-inst vm-eq? 130 ()
757   (inst pop reg1)
758   (inst pop reg2)
759   (inst mov reg3 SCM_BOOL_T)
760   (inst cmp reg1 reg2)
761   (inst jmp #:eq out:)
762   (inst mov reg3 SCM_BOOL_F)
763  out:
764   (inst push reg3))
765
766
767
768 (define-vm-inst vm-not-eq? 131 ()
769   (inst pop reg1)
770   (inst pop reg2)
771   (inst mov reg3 SCM_BOOL_F)
772   (inst cmp reg1 reg2)
773   (inst jmp #:eq out:)
774   (inst mov reg3 SCM_BOOL_T)
775  out:
776   (inst push reg3))
777
778 (define-vm-inst vm-null? 132 ()
779   (inst pop reg1)
780   (inst mov reg2 SCM_BOOL_T)
781   (inst cmp reg1 SCM_EOL)
782   (inst jmp #:eq out:)
783   (inst mov reg2 SCM_BOOL_F)
784  out:
785   (inst push reg2))
786
787 (define-vm-inst vm-not-null? 133 ()
788   (inst pop reg1)
789   (inst mov reg2 SCM_BOOL_F)
790   (inst cmp reg1 SCM_EOL)
791   (inst jmp #:eq out:)
792   (inst mov reg2 SCM_BOOL_T)
793  out:
794   (inst push reg2))
795
796 #;
797 (define-vm-inst vm-eqv? 134 ()
798   (inst pop reg1)
799   (inst pop reg2)
800   (inst mov reg3 SCM_BOOL_T)
801   (inst cmp reg1 reg2)
802   (inst jmp #:eq out:)
803   (inst mov reg3 SCM_BOOL_F)
804   (inst test reg1 7)
805   (inst jmp #:neq out:)
806   (inst test reg2 7)
807   (inst jmp #:neq out:)
808   (inst mov ret (&& next:))
809   (inst jmp (eqv?-hook))
810  out:
811   (push reg3)
812  next:)
813
814
815 #;
816 (define-vm-inst vm-equal? 135 ()
817   (inst pop reg1)
818   (inst pop reg2)
819   (inst mov reg3 SCM_BOOL_T)
820   (inst cmp reg1 reg2)
821   (inst jmp #:eq out:)
822   (inst mov reg3 SCM_BOOL_F)
823   (inst test reg1 7)
824   (inst jmp #:neq out:)
825   (inst test reg2 7)
826   (inst jmp #:neq out:)
827   (inst mov ret (&& next:))
828   (inst jmp (equal?-hook))
829  out:
830   (push reg3)
831   next:)
832
833
834 (define-vm-inst vm-pair? 136 ()
835   (inst pop reg1)
836   (inst mov reg2 SCM_BOOL_F)
837   (inst test reg1 7)
838   (inst jmp #:nz out:)
839   (inst mov reg1 (Q reg1))
840   (inst test reg1 1)
841   (inst jmp #:nz out:)
842   (inst mov reg2 SCM_BOOL_T)
843  out:
844   (inst push reg2))
845
846 #;
847 (define-vm-inst vm-list? 137 ()
848   (gosub-hook list?-hook))
849
850 #;
851 (define-vm-inst vm-symbol? 138 ()
852   (type tc7_symbol))
853
854 #;
855 (define-vm-inst vm-vector? 139 ()
856   (type tc7_vector))
857
858
859 (define-vm-inst vm-cons 140 ()
860   (inst pop call-2)
861   (inst pop call-1)
862   (c-call scm_cons call-1 call-2)
863   (inst push rax))
864
865
866 (define-vm-inst vm-car 141 ()
867   (inst pop reg1)
868   (inst test reg1 7)
869   (inst jmp #:nz car-error:)
870   (inst mov reg1 (Q reg1))
871   (inst test reg1 1)
872   (inst jmp #:nz car-error:)
873   (inst push reg1)
874   (inst jmp out:)
875  car-error:
876   (c-call scm_car_error)
877  out:)
878
879
880 (define-vm-inst vm-cdr 142 ()
881   (inst pop reg1)
882   #;(inst test reg1 7)
883   #;(inst jmp #:nz cdr-error:)
884   #;(inst test (Q reg1) 1)
885   #;(inst jmp #:nz cdr-error:)
886   (inst push (Q reg1 1))
887   #;(inst jmp out:)
888  #;cdr-error:
889   #;(c-call scm_cdr_error)
890  #;out:)
891
892 (define-vm-inst vm-set-car! 143 ()
893   (inst pop reg2)
894   (inst pop reg1)
895   (inst test reg1 7)
896   (inst jmp #:nz car-error:)
897   (inst mov reg3 (Q reg1))
898   (inst test reg3 1)
899   (inst jmp #:nz car-error:)
900   (inst mov (Q reg1) reg2 )
901   (inst jmp out:)
902  car-error:
903   (c-call scm_setcar_error)
904  out:)
905
906 (define-vm-inst vm-set-cdr! 144 ()
907   (inst pop reg2)
908   (inst pop reg1)
909   (inst test reg1 7)
910   (inst jmp #:nz car-error:)
911   (inst mov reg3 (Q reg1))
912   (inst test reg3 1)
913   (inst jmp #:nz car-error:)
914   (inst mov (Q reg1 1) reg2)
915   (inst jmp out:)
916  car-error:
917   (c-call scm_setcdr_error)
918  out:)
919
920 (define (CMP jumper c-code)
921   (assemble ()
922     (inst pop call-2)
923     (inst pop call-1)
924     (inst test call-1 2)
925     (inst jmp #:z slow:)
926     (inst test call-1 2)
927     (inst jmp #:z slow:)
928     (inst mov reg1 SCM_BOOL_T)
929     (inst cmp call-1 call-2)
930     (inst jmp jumper out:)
931     (inst jmp false:)
932    slow:
933     (c-call c-code)
934     (inst jmp out:)
935    false:
936     (inst mov reg1 SCM_BOOL_F)
937    out:
938     (inst push reg1)))
939
940 (define-vm-inst ee? 145 ()
941   (CMP #:eq scm_num_eq_p))
942
943 (define-vm-inst lt? 146 ()
944   (CMP #:l scm_less_p))
945
946 (define-vm-inst le? 147 ()
947   (CMP #:le scm_leq_p))
948
949 (define-vm-inst gt? 148 ()
950   (CMP #:g scm_gr_p))
951
952 (define-vm-inst ge? 149 ()
953   (CMP #:ge scm_geq_p))
954
955 (define-vm-inst vm-add 150 ()
956   (inst pop call-1)
957   (inst mov call-2 (Q rsp))
958   (inst test call-1 2)
959   (inst jmp #:z slow:)
960   (inst test call-2 2)
961   (inst jmp #:z slow:)
962   (inst add call-2 call-1)
963   (inst jmp #:o slow:)
964   (inst sub call-2 2)
965   (inst mov (Q rsp) call-2)
966   (inst jmp out:)
967  slow:
968   (inst mov call-2 (Q rsp))
969   (c-call scm_sum call-1 call-2)
970   (inst mov (Q rsp) rax)
971  out:)
972
973 (define-vm-inst vm-inc 151 ()
974   (inst mov reg1 (Q rsp))
975   (inst test reg1 2)
976   (inst jmp #:z slow:)
977   (inst add reg1 4)
978   (inst jmp #:o slow:)
979   (inst jmp out:)
980  slow:
981   (inst mov call-1 (Q rsp))
982   (inst mov call-2 6)
983   (c-call scm_sum call-1 call-2)
984  out:
985   (inst mov (Q rsp) reg1))
986
987
988 (define-vm-inst vm-sub 152 ()
989   (inst pop call-1)
990   (inst mov call-2 (Q rsp))
991   (inst test call-1 2)
992   (inst jmp #:z slow:)
993   (inst test call-2 2)
994   (inst jmp #:z slow:)
995   (inst sub call-2 call-1)
996   (inst jmp #:o slow:)
997   (inst add call-2 2)
998   (inst mov (Q rsp) call-2)
999   (inst jmp out:)
1000  slow:
1001   (inst mov call-2 (Q rsp))
1002   (c-call scm_difference call-2 call-1)
1003   (inst mov (Q rsp) rax)
1004  out:)
1005
1006 (define-vm-inst vm-dec 153 ()
1007   (inst mov reg1 (Q rsp))
1008   (inst test reg1 2)
1009   (inst jmp #:z slow:)
1010   (inst sub reg1 4)
1011   (inst jmp #:o slow:)
1012   (inst jmp out:)
1013  slow:
1014   (inst mov call-1 (Q rsp))
1015   (inst mov call-2 6)
1016   (c-call scm_difference call-1 call-2)
1017  out:
1018   (inst mov (Q rsp) reg1))
1019
1020 (define-vm-inst vm-mul 154 ()
1021   (inst pop call-2)
1022   (inst pop call-1)
1023   (c-call scm_product)
1024   (inst push rax))
1025
1026 (define-vm-inst vm-div 155 ()
1027   (inst pop call-2)
1028   (inst pop call-1)
1029   (c-call scm_divide)
1030   (inst push rax))
1031
1032 (define-vm-inst vm-quo 156 ()
1033   (inst pop call-2)
1034   (inst pop call-1)
1035   (c-call scm_quotient)
1036   (inst push rax))
1037
1038 (define-vm-inst vm-rem 157 ()
1039   (inst pop call-2)
1040   (inst pop call-1)
1041   (c-call scm_remainder)
1042   (inst push rax))
1043
1044 (define-vm-inst vm-mod 158 ()
1045   (inst pop call-2)
1046   (inst pop call-1)
1047   (c-call scm_modulo)
1048   (inst push rax))
1049
1050 ;;TODO this should be an inline asembly
1051 (define-vm-inst vm-ash 159 ()
1052   (inst pop  rsi)
1053   (inst mov  rdi (Q rsp))
1054   (inst test dil 2)
1055   (inst jmp  #:z slow:)
1056   (inst test sil 2)
1057   (inst jmp  #:z slow:)
1058   (inst sar  rsi 2)
1059   (inst test rsi rsi)
1060   (inst jmp  #:s neg:)
1061   (inst cmp  rsi 60)
1062   (inst jmp  #:a slow:)
1063   (inst sar  rdi 2)
1064   (inst mov  ecx 61)
1065   (inst sub  ecx esi)
1066   (inst mov  rdx rdi)
1067   (inst sar  rdx #:cl)
1068   (inst add  rdx 1)
1069   (inst cmp  rdx 1)
1070   (inst jmp  #:a slow:)
1071   (inst mov  ecx esi)
1072   (inst sal  rdi #:cl)
1073   (inst jmp last:)
1074  slow:
1075   (inst mov call-2 (Q rsp -1))
1076   (inst mov call-1 (Q rsp  0))
1077   (c-call scm_ash)
1078   (inst jmp  final:)
1079  neg:
1080   (inst mov  ecx esi)
1081   (inst sar  rdi 2)
1082   (inst neg  ecx)
1083   (inst sar  rdi #:cl)
1084  last:
1085   (inst lea  rax (make-ea #:qword #:disp 2 #:index rdi #:scale 4)) ;;rax <- 4*rdi + 2
1086  final:
1087   (inst mov  (Q rsp) rax))
1088
1089 (define-vm-inst vm-logand 160 ()
1090   (inst pop call-2)
1091   (inst mov call-1 (Q rsp))
1092   (inst test call-1 2)
1093   (inst jmp #:z slow:)
1094   (inst test call-2 2)
1095   (inst jmp #:z slow:)
1096   (inst and call-2 call-1)
1097   (inst mov (Q rsp) call-2)
1098   (inst jmp out:)
1099  slow:
1100   (c-call scm_logand)
1101   (inst mov (Q rsp) rax)
1102  out:)
1103  
1104 (define-vm-inst vm-logior 161 ()
1105   (inst pop call-2)
1106   (inst mov call-1 (Q rsp))
1107   (inst test call-1 2)
1108   (inst jmp #:z slow:)
1109   (inst test call-2 2)
1110   (inst jmp #:z slow:)
1111   (inst or call-2 call-1)
1112   (inst mov (Q rsp) call-2)
1113   (inst jmp out:)
1114  slow:
1115   (c-call scm_logior)
1116   (inst mov (Q rsp) rax)
1117  out:)
1118
1119 (define-vm-inst vm-logxor 162 ()
1120   (inst pop call-2)
1121   (inst mov call-1 (Q rsp))
1122   (inst test call-1 2)
1123   (inst jmp #:z slow:)
1124   (inst test call-2 2)
1125   (inst jmp #:z slow:)
1126   (inst xor call-2 call-1)
1127   (inst add call-2 2)
1128   (inst mov (Q rsp) call-2)
1129   (inst jmp out:)
1130  slow:
1131   (c-call scm_logxor)
1132   (inst mov (Q rsp) rax)
1133  out:)
1134