Some more instructions tested, added reentrant call's that are needed for instruction...
[aschm:aschm.git] / module / native / vm / vm.scm
1 (define-module (native vm vm)
2   #:use-module (system vm program)
3   #:use-module (native aschm)
4   #:use-module (native vm base)  
5   #:use-module (native vm bit-utilities)
6   #:export (local-ref get-object get-object-ref get-free get-program 
7                       get-C reg1 reg2 reg3 reg4 reg5
8                       make-c-caller *c-stubs* ret init-native-vm jmp vm
9                       vm-rbx vm-r12 vm-r14 vm-clo vm-obj cur_th
10                       save-1 save-2 save-3 save-4 callwr
11                       vm-trace-level vm-stack-limit vm-rsp vm-rsp-a vm-rbp-a
12                       vm-nargs))
13
14 ;; x86-64 rbp rbx r12 and r14 are callee saved registers.
15 ;; rbx is used for shared library lookup tables
16 (define vm      r12)
17 (define jmp     r14)
18
19
20 (define n 0)        
21 (define-syntax-rule (mk-v name reg)
22   (begin
23     (define name
24       (let ((n (- n)))
25         (case-lambda
26           (()    (Q reg n))
27           ((reg) (Q reg n)))))   
28     (set! n (+ n 1))))
29
30 ;;vm variables defined here
31 ;;we are defensive and don't use many registers yet
32 (mk-v vm-rbx    vm)
33 (mk-v vm-r12    vm)
34 (mk-v vm-r14    vm)
35 (mk-v vm-c      vm)
36 (mk-v vm-return vm)
37 (mk-v vm-mv-return vm)
38 (mk-v ret       vm)
39 (mk-v cur_th    vm)
40 (mk-v callwr    vm)
41 (mk-v vm-rsp    vm)
42 (mk-v vm-rsp-a  vm)
43 (mk-v vm-C-rsp  vm)
44 (mk-v vm-rbp-a  vm)
45 (mk-v vm-C-rbp  vm)
46 (mk-v vm-nargs  vm)
47 (mk-v vm-trace-level vm)
48 (mk-v vm-stack-limit vm)
49 (mk-v save-1    vm)
50 (mk-v save-2    vm)
51 (mk-v save-3    vm)
52 (mk-v save-4    vm)
53
54 (define local-ref
55   (case-lambda
56     ((n)         (Q rbp n))
57     ((rbp . l)   (apply Q rbp l))))
58
59 (define (get-program reg) (Q reg 0))
60 (define (get-object x reg)
61   (assemble ()
62     (inst mov reg (vm-obj))
63     (inst mov reg (Q reg x))))
64
65 (define (get-object-ref x reg)
66   (assemble ()
67     (inst mov reg (vm-obj))
68     (inst lea reg (Q reg x))))
69
70 (define (get-free x reg)
71   (assemble ()
72     (inst mov reg (vm-clo))
73     (inst mov reg (Q reg x))))
74
75 (define (get-C x reg)
76   (assemble ()
77     (inst mov reg (vm-c))
78     (inst mov reg (Q reg x))))
79
80
81 (define reg1 rax)
82 (define reg2 r10)
83 (define reg3 r13)
84 (define reg4 r15)
85 (define reg5 r11)
86
87 ;; call this stub first at init as
88 ;; vm2 =  vm(&jmpmap)
89 ;; Then afterwords us 
90 ;; ret = vm2(&jmpmap,&freevars,&objecttable,&c-codemap,&code)
91 ;; native_vm(jmpmap, free, fp, 
92 ;;                   c_call_table, code, sp, (long) nargs, program, cth, 
93 ;;                   call_wrapper);
94 (define (vm-stub)
95   (asm
96    ;;First call arg1 contains the addres of the goto map fill it in and return
97    ;;The adress to the actual function stub
98    (for-each (lambda (f) (f 'set-jmp-map rdi rax)) *jmp-hooks*)
99    (inst mov rax (&& second:))
100    (inst ret)
101
102   second:     
103    ;; rbp
104    (inst mov reg1 rbp)
105    (inst mov rbp (Q rdx)) ;; rdx = &fp
106
107    ;; rsp
108    (inst mov reg2 rsp)
109
110    ;; vm
111    (inst mov reg3 vm)
112    (inst push 0)
113    (inst mov vm  rsp)
114    (inst add rsp (* (- n) 8))
115
116    (inst mov (vm-C-rbp) reg1)
117    (inst mov (vm-C-rsp) reg2)
118    
119    (inst mov (vm-rbp-a) rdx)
120
121    ;;Save rbx,r12,r14 for as described by the calling convention   
122    (inst mov (vm-rbx) rbx)
123    (inst mov (vm-r12) reg3) ;; old value of the vm register is saved
124    (inst mov (vm-r14) r14)
125
126    (inst mov rbx 0)
127
128    ;; nargs
129    (inst mov reg1 (Q vm 2))
130    (inst mov (vm-nargs) reg1)
131    
132    ;;current_thread needs to be imported
133    (inst mov reg4 (Q vm 4))
134    (inst mov (cur_th) reg4)
135
136    ;;the call-wrapper needs to be saved
137    (inst mov reg4 (Q vm 5))
138    (inst mov (callwr) reg4)
139
140    ;;rsp
141    (inst mov reg1       (Q r9))
142    (inst mov (vm-rsp)    reg1)
143
144    (inst mov (vm-rsp-a)  r9)
145
146    ;;c-calltable
147    (inst mov (vm-c) rcx)
148
149    ;;jmp
150    (inst mov jmp rdi)
151
152    ;;stack limit
153    (inst mov (vm-stack-limit) rsi);
154
155    ;;Change the call environment
156    (inst mov reg4 (return-a rbp))
157    (inst mov (vm-return) reg4)
158    (inst mov reg4 (&& ret:))   
159    (inst mov (return-a rbp) reg4)
160
161    (inst mov reg4 (mv-return-a rbp))
162    (inst mov (vm-mv-return) reg4)
163    (inst mov reg4 (&& mv-ret:))
164    (inst mov (mv-return-a rbp) reg4)
165    
166    ;; Goto the supplied function
167    (inst jmp r8)
168    
169   ret:
170    (inst mov reg1 (vm-return))
171    (inst jmp cont:)
172   mv-ret:
173    (inst mov reg1 (vm-mv-return))
174   cont:
175    ;; Restore the saved registers   
176   
177    ;; save the current rbp value
178    (inst mov reg3 (vm-rbp-a))
179    (inst mov (Q reg3) rbp)
180
181    (inst mov r14 (vm-r14))
182    (inst mov rbx (vm-rbx))
183    (inst mov rsp (vm-C-rsp))
184    (inst mov rbp (vm-C-rbp))
185
186    ;; set new value of rsp
187    (inst mov reg3 (vm-rsp-a))
188    (inst mov reg4 (vm-rsp))
189    (inst mov (Q reg3) reg4)
190
191    (inst mov reg2 vm)
192    (inst mov vm  (vm-r12))
193
194    (inst ret)
195
196    ;;emit the goto hooks
197    (for-each (lambda (f) (f 'emit)) *jmp-hooks*)
198    ))
199
200 (define (init-native-vm)
201   (let ((vm (vm-stub)))
202     (mk-rwx vm)
203     (native-vm-set! vm)))