all noncommented rtl ops are now encoded
[aschm:aschm.git] / module / native / vm / base.scm
1 (define-module (native vm base)
2   #:use-module (native vm bit-utilities)
3   #:use-module (native vm constants)
4   #:use-module (native aschm)
5   #:use-module (ice-9 match)
6   #:export (*vm-instr* *vm-jump* *jmp-hooks* define-vm-inst define-vm-inst-jmp
7                        define-jmp-hook 
8                        make-byte-stream read-byte
9                        U8_U24 X8_U24 X8_R24 X8_L24 U8_U12_U12 U1_X7_L24
10                        U8_L24 L32 U8_U8_I16 I32 A32 B32 S32 U8_U8_U8_U8
11                        N32 U8_X24 U32 X8_U12_U12
12                        IP N Label))
13
14
15 (define *vm-instr* (make-vector 500 #f))
16 (define *vm-jump*  (make-vector 500 #f))
17
18 (define-syntax-rule (digest U8_U24 u32 (u8 v) ...)
19   (define-syntax-rule (U8_U24 Let a n lab (args (... ...)) u8 ...
20                               ((cont co (... ...)) . l))
21     (Let ((u32 (u32vector-ref a n))
22           (u8 v) ...)
23       (cont Let a (+ n 1) lab (args (... ...) u8 ...) co (... ...) l))))
24
25 (digest U8_X24 u32
26         (x8  (ash    u32 -24)))
27
28 (digest U8_U24 u32
29         (x8  (ash    u32 -24))
30         (x24 (logand u32 #xffffff)))
31
32 (digest U8_U12_U12 u32
33         (x8  (ash    u32 -24))
34         (x12 (ash (logand u32 #xffffff) -12))
35         (y12 (logand u32 #xfff)))
36
37 (digest X8_U12_U12 u32
38         (x12 (ash (logand u32 #xffffff) -12))
39         (y12 (logand u32 #xfff)))
40
41 (digest U8_U8_U8_U8 u32
42         (x8  (ash    u32 -24))
43         (y8 (ash (logand u32 #xffffff) -16))
44         (z8 (ash (logand u32 #xffff) -8))
45         (w8 (logand u32 #xff)))
46
47 (digest U8_U8_I16 u32
48         (x8  (ash    u32 -24))
49         (y8  (ash (logand u32 #xffffff) -16))
50         (x16 (logand u32 #xffff)))
51
52 (digest L32    u32
53         (l32 (S32_ u32)))
54
55 (digest I32    u32
56         (l32   u32))
57 (digest U32    u32
58         (l32   u32))
59 (digest A32    u32
60         (l32   u32))
61 (digest B32    u32
62         (l32   u32))
63 (digest S32    u32
64         (l32   (S32_ u32)))
65 (digest N32    u32
66         (l32   (S32_ u32)))
67
68 (digest X8_U24 u32
69         (x24 (logand u32 #xffffff)))
70
71 (digest X8_R24 u32
72         (x24 (logand u32 #xffffff)))
73
74 (digest X8_L24 u32
75         (offset (S24 u32)))
76
77 (digest U8_L24 u32
78         (x8  (ash    u32 -24))
79         (offset (S24 u32)))
80
81 (digest U1_X7_L24 u32
82         (x1  (ash u32 -31))
83         (x24 (S24 u32)))
84
85 (define-syntax-rule (IP Let a n lab (args ...) ip offset ((cont co ...) . l)) 
86   (Let ((ip (+ (get-bytevector-adress a) n)))
87     (cont Let a n lab (args ... ip) co ... l)))
88
89 (define-syntax-rule (N Let a n lab (args ...) l m ((cont co ...)))
90   (Let ((l (let loop ((i m) (l '())) 
91              (if (= i 0)
92                  l
93                  (loop (- i 1) (cons (u32vector-ref a (+ n i)) l))))))
94     (cont Let a (+ n (+ 1 m)) lab (args ... l) co ... '())))
95
96 (define-syntax-rule (Label Let a n (lab ...) args addr expr ((cont co ...) . l))
97   (Let ((addr expr))
98     (cont Let a n (lab ... addr) args  co ... l)))
99
100 (define-syntax-rule (ID Let a n lab args u ... ((cont co ...) . l))
101   (cont Let a n lab args co ... l))
102
103 (define-syntax-rule (MK-JMP _  a nn (jmp ...) (arg ...) _)
104   (lambda (table i)
105     (cons nn
106           (list
107            (let* ((n (+ i jmp))
108                   (x (hashq-ref table n)))
109              (if x
110                  x
111                  (let ((x (make-label)))
112                    (hashq-set! table n x)
113                    x)))
114            ...))))
115
116 (define-syntax-rule (MK-INST _ a nn (jmp ...) (arg ...) f _)
117   (lambda (jmp ...)
118     (cons nn (f jmp ... arg ...))))
119
120 (define-syntax-rule (LAMBDA _ _ _  (jmp ...) (arg ...) code ... _)
121   (lambda (jmp ... arg ...) (assemble () code ...)))
122
123 (define-syntax-rule  (skip x . l) (begin . l))
124
125 (define-syntax define-vm-inst
126   (syntax-rules () 
127     ((define-vm-inst nm id ((cont co ...) l ...) code ...)
128      (begin
129        (define nm (cont skip #f #f () () bc co ... (l ... (LAMBDA code ...))))
130        (vector-set! *vm-jump* id (lambda (a n)
131                                    (cont let* a n () () bc co ... 
132                                          (l ... 
133                                             (MK-JMP)))))
134
135        (vector-set! *vm-instr* id (lambda (a n)
136                                     (cont let* a n () () bc co ... 
137                                           (l ... 
138                                              (MK-INST nm)))))))
139     ((define-vm-inst nm id () code ...)
140      (define-vm-inst nm id ((ID)) code ...))))
141
142 (define *jmp-hooks* '())
143 (define hook-i 0)
144 (define (add-hook x) (set! *jmp-hooks* (cons x *jmp-hooks*)))
145 (define-syntax-rule (define-jmp-hook name code ...)
146   (begin
147     (define name (let ((i     hook-i)
148                        (label (make-label)))
149                    (add-hook
150                     (lambda x
151                       (match x
152                         (('set-jmp-map jmp reg)
153                          (assemble () 
154                            (inst mov reg (&& label))
155                            (inst mov (Q jmp i) reg)))
156                         (('emit)
157                          (assemble () (emit-label label) code ...)))))
158                    (lambda (reg) (Q reg i))))
159     (set! hook-i (+ hook-i 1))))
160
161 (define (make-byte-stream bv) (cons 0 bv))
162 (define (read-byte s) 
163   (let* ((i (car s))
164          (r (u8vector-ref (cdr s) i)))
165     (set-car! s (+ i 1))
166     r))