1;; lib/vm.scm
2#!core
3;; dummy
4(define *toplevel-variable* '())
5(define *expand-phase* 0)
6(define (vm-r6rs-mode?) #f)
7;; in case
8(define (vm-slice-let-syntax?) #f)
9(define (vm-noinline-locals?) #f)
10(define (vm-nolambda-lifting?) #f)
11(define (vm-nolibrary-inlining?) #f)
12(define (vm-noconstant-inlining?) #f)
13(define (vm-macro-expand-phase?)
14  (positive? *expand-phase*))
15
16(define (set-toplevel-variable! sym val)
17  (set! *toplevel-variable* (acons sym val *toplevel-variable*)))
18(define (gloc-ref g) g)
19(define (gloc-bound? g) #t)
20(define (gloc-const? g)
21  ;; not so good, but for booting we don't do global set! so, it's ok.
22  (or (string? g)
23      (number? g)
24      ;; vector can not be const for boot code.
25      #;(vector? g)))
26;; on boot code we don't have set! or redefine ... I assume
27(define (gloc-library g) #f)
28
29(define (cachable? o)
30  (or (string? o) (number? o) (symbol? o)))
31
32(define (vm-warn msg)
33  ;; it was too much to see...
34  #;(format (current-error-port) "WARNING: ~a~%" msg))
35
36;; for declare-procedure
37(define (parse-type type)
38  (if (and (pair? type)
39	   (= (length type) 2))
40      (cadr type)
41      #f))
42
43;; this file is the collection of vm procedure.
44;; these procedure must be written in C++
45(define (insn-name insn)
46  (let ((info (lookup-insn-name insn)))
47    (car info)))
48
49;; for better performance.
50;; this will be called so many times in compiler.scm
51(define p1env-lookup
52  (lambda (p1env name lookup-as)
53    (let ((name-ident? (identifier? name))
54	  (frames (vector-ref p1env 1))
55	  (oname name)
56	  (ret #f))
57      (let loop ((fp frames))
58	(cond ((pair? fp)
59	       (when (and name-ident? (eq? (id-envs name) fp))
60		 (set! name-ident? #f) ;; given name is no longer identifier
61		 (set! name (id-name name)))
62	       (if (> (caar fp) lookup-as)
63		   (loop (cdr fp))
64		   (let loop2 ((tmp (cdar fp)))
65		     (if (pair? tmp)
66			 (let ((vp (car tmp)))
67			   (if (eq? name (car vp))
68			       (cdr vp)
69			       (loop2 (cdr tmp))))
70			 (loop (cdr fp))))))
71	      (else
72	       (if (symbol? name)
73		   (make-identifier name '() (vector-ref p1env 0))
74		   name)))))))
75
76(define p1env-pvar-lookup
77  (lambda (p1env name)
78    (let ((name-ident? (identifier? name))
79	  (frames (vector-ref p1env 1))
80	  (ret #f)
81	  (dummy #f))
82      (when name-ident?
83	(set! dummy `#(,(id-library name) ,(id-envs name))))
84      (let loop ((fp frames))
85	(cond ((pair? fp)
86	       (when (> (caar fp) 2)
87		 (loop (cdr fp)))
88	       (let loop2 ((tmp (cdar fp)))
89		 (if (pair? tmp)
90		     (let ((vp (car tmp)))
91		       (if (and name-ident?
92				(identifier=? p1env name dummy (car vp)))
93			   (cdr vp)
94			   (loop2 (cdr tmp))))
95		     (loop (cdr fp)))))
96	      (else
97	       (if (symbol? name)
98		   (make-identifier name '() (vector-ref p1env 0))
99		   name)))))))
100
101(define p1env-toplevel?
102  (lambda (p1env)
103    (not (any (lambda (frame) (eqv? (car frame) LEXICAL))
104	      (vector-ref p1env 1)))))
105
106;;==========================================================================
107;; Identifiers:
108;;
109;; <name>             ::= <symbol>
110;; <envs>             ::= (<env> ...)
111;; <library>          ::= (<symbol> ...) | #f
112;; <rename?>          ::= #f | #t
113;;
114;; where
115;;   <name>             : The symbolic name of the identifier in the source.
116;;   <envs>             : p1env frames
117;;   <library>          : Library name.
118;;   <rename?>          : only appears in macro expansion
119(define make-identifier
120  (lambda (name envs library)
121    (vector '.identifier
122	    name
123	    (if (null? envs)
124		'()
125		(get-binding-frame name envs))
126	    (find-library library #f)
127	    ;; for bound-id->symbol
128	    (gensym)
129	    #f
130	    #f)))
131
132(define (rename-pending-identifier! id) id)
133
134(define (rename-id id)
135  (if (identifier? id)
136      (let ((new-id (make-identifier (id-name id) (id-envs id) (id-library id))))
137	(id-renamed?-set! new-id)
138	(id-transformers-env-set! new-id (current-usage-env))
139	new-id)
140      (let ((new-id (make-identifier id '() (vm-current-library))))
141	(id-renamed?-set! new-id)
142	(id-transformers-env-set! new-id (current-usage-env))
143	new-id)))
144
145(define (id-name id)
146  (vector-ref id 1))
147(define (id-name-set! id v)
148  (vector-set! id 1 v))
149(define (id-envs id)
150  (vector-ref id 2))
151(define (id-envs-set! id v)
152  (vector-set! id 2 v))
153(define (id-library id)
154  (vector-ref id 3))
155(define (id-library-set! id v)
156  (vector-set! id 3 v))
157(define (id-renamed? id)
158  (vector-ref id 5))
159(define (id-renamed?-set! id)
160  (vector-set! id 5 #t))
161
162(define (id-transformers-env id)
163  (vector-ref id 6))
164(define (id-transformers-env-set! id e)
165  (vector-set! id 6 e))
166
167(define (renamed-id? id)
168  (and (identifier? id)
169       (id-renamed? id)))
170
171(define (bound-id->symbol id)
172  (let ((n (format "~a~a"
173		   (id-name id)
174		   (vector-ref id 4))))
175    (string->symbol n)))
176
177(define copy-identifier
178  (lambda (id)
179    (make-identifier (id-name id)
180		     (id-envs id)
181		     (id-library id))))
182
183(define get-binding-frame
184  (lambda (var env)
185    (let loop ((frame env))
186      (if (pair? frame)
187	  (if (pair? (car frame))
188	      (let loop2 ((fp (cdar frame)))
189		(if (pair? fp)
190		    (if (eq? (caar fp) var)
191			frame
192			(loop2 (cdr fp)))
193		    (loop (cdr frame))))
194	      (loop (cdr frame)))
195	  '()))))
196(define identifier-binding-eqv?
197  (lambda (id sym env)
198    (let ((bf (get-binding-frame sym env)))
199      (eq? bf (id-envs id)))))
200
201;; Sagittarius library systam
202;; Top libraries
203;; Just a hashtable: <key>   = library name
204;;                   <value> = library
205;; Each library
206;; - name          : this library's name
207;; - imported      : imported symbols for this library
208;; - exported      : exported symbols from whis library
209;; - binding table : binding table.
210;; - transient     : #t not import after converted to c
211;; - defined       : temporary storage for macro expansion
212;;                   this contains all defined variables in this library.
213
214;; libraries
215;; this might be like this
216;; hashtable -> ((version) . library instance)
217;; ((lib1 => (((1) . <library>)
218;;	      ((2) . <library>))
219;; but on scheme VM it's just hashtable to be simple.
220(define *libraries* (make-hashtable equal-hash equal?))
221(define (make-library library)
222  (let ((lib (vector '.library library '() #f (make-eq-hashtable) #f '())))
223    (hashtable-set! *libraries* library lib)
224    lib))
225
226(define (library? lib)
227  (and (vector? lib)
228       (> (vector-length lib) 1)
229       (eq? (vector-ref lib 0) '.library)))
230(define (library-name lib)
231  (vector-ref lib 1))
232(define (library-imported lib)
233  (vector-ref lib 2))
234(define (library-imported-set! lib spec)
235  (vector-set! lib 2 spec))
236(define (library-exported lib)
237  (vector-ref lib 3))
238(define (library-exported-set! lib spec)
239  (vector-set! lib 3 spec))
240(define (library-table lib)
241  (vector-ref lib 4))
242(define (library-transient lib)
243  (vector-ref lib 5))
244(define (library-transient-set! lib val)
245  (vector-set! lib 5 val))
246(define (library-defined lib)
247  (vector-ref lib 6))
248(define (library-defined-add! lib val)
249  (let ((r (cons (if (identifier? val) (id-name val) val)
250		 (vector-ref lib 6))))
251    (vector-set! lib 6 r)))
252
253(define (%set-library lib)
254  (or (library? lib)
255      (error "library required but got " lib))
256  (hashtable-set! #;(vm-libraries) *libraries* (library-name lib) lib))
257;; TODO version number...
258(define (find-library name create?)
259  (if (library? name)
260      name
261      (let ((l (hashtable-ref #;(vm-libraries) *libraries* name #f)))
262	(or l
263	    (if create?
264		(make-library name)
265		l)))))
266
267(define (%insert-binding library name value)
268  (define (add-export lib name)
269    (if (library-exported lib)
270	(library-exported-set! lib (cons name (library-exported lib)))
271	(library-exported-set! lib (list name))))
272
273  (cond ((library? library)
274	 (hashtable-set! (library-table library) name value))
275	((hashtable-ref #;(vm-libraries) *libraries* library #f) ;; maybe just a name?
276	 => (lambda (v)
277	      (hashtable-set! (library-table v) name value)))
278	((not library)
279	 (%insert-binding (vm-current-library) name value))
280	(else
281	 (let ((lib (make-library library)))
282	   (hashtable-set! (library-table lib) name value)))))
283
284(define (find-binding lib name callback)
285  (cond ((library? lib)
286	 (let ((r (hashtable-ref (library-table lib) name #f)))
287	   (if r
288	       r
289	       (cond ((assq name *toplevel-variable*)
290		      => cdr)
291		     (else callback)))))
292	((hashtable-ref *libraries* lib callback) ;; maybe just a name?
293	 => (lambda (lib)
294	      (let ((r (hashtable-ref (library-table lib) name #f)))
295		(if r
296		    r
297		    (cond ((assq name *toplevel-variable*)
298			   => cdr)
299			  (else callback))))))
300	((not lib)
301	 (find-binding (vm-current-library) name callback))
302	(else callback)))
303
304;(define *compiler-library* '(sagittarius compiler))
305(define *current-library* 'user)
306(define vm-current-library
307  (lambda name
308    (if (null? name)
309	*current-library*
310	(set! *current-library* (car name)))))
311
312;; just stub
313(define (import-library to from resolved-spec trans?)
314  (if trans?
315      (library-transient-set! from #t)
316      (library-transient-set! from #f))
317  (let* ((lib (if (library? from)
318		    from
319		    (find-library from #f)))
320	 (export-spec (library-exported lib)))
321    (when (and lib
322	       #;(not (assq lib (library-imported to))))
323      (unless (assq lib (library-imported to))
324	(library-imported-set! to
325			       (acons lib
326				      export-spec
327				      (library-imported to))))
328      (if (and export-spec (memq :all (car export-spec)))
329	  (hashtable-for-each
330	   (lambda (k v) (hashtable-set! (library-table to) k v))
331	   (library-table lib))
332	  (hashtable-for-each
333	   (lambda (k v)
334	     (cond ((not export-spec)
335		    ;; maybe null or user library
336		    (hashtable-set! (library-table to) k v))
337		   ((memq k (car export-spec))
338		    ;; no rename just put
339		    (hashtable-set! (library-table to) k v))
340		   ((assq k (cdr export-spec)) =>
341		    (lambda (spec)
342		      (hashtable-set! (library-table to) (cdr spec) v)))))
343	   (library-table lib))))))
344;; for vm.scm
345(define (load-library to . from)
346  (let loop ((from from))
347    (if (null? from)
348	#t
349	(let ((name (car from)))
350	  (let* ((lib (if (library? name)
351			  name
352			  (find-library name #f)))
353		 (export-spec (library-exported lib)))
354	    (when (and lib
355		       #;(not (assq lib (library-imported to))))
356	      (unless (assq lib (library-imported to))
357		(library-imported-set! to
358				       (acons lib
359					      export-spec
360					      (library-imported to))))
361	      (hashtable-for-each
362	       (lambda (k v)
363		 (cond ((not export-spec)
364			;; maybe null or user library
365			(hashtable-set! (library-table to) k v))
366		       ((memq k (car export-spec))
367			;; no rename just put
368			(hashtable-set! (library-table to) k v))
369		       ((assq k (cdr export-spec)) =>
370			(lambda (spec)
371			  (hashtable-set! (library-table to) (cdr spec) v)))))
372	       (library-table lib)))
373	    (loop (cdr from)))))))
374
375#;(define (import-only to from symbols)
376  (library-imported-set! to
377			 (acons from symbols (library-imported to)))
378  (for-each (lambda (sym)
379	      (hashtable-set! (library-table to)
380			      sym
381			      (hashtable-ref (library-table from)
382					     sym)))
383	    symbols))
384
385#;(define (import-rename to from rename prefix?)
386  (define (add-prefix prefix)
387    (let ((keys (hashtable-keys (library-table from))))
388      (let loop ((keys keys)
389		 (r '()))
390	(cond ((null? keys) r)
391	      (else
392	       (let ((renamed (string->symbol
393			       (string-append (symbol->string prefix)
394					      (symbol->string (car keys))))))
395		 (loop (cdr keys) (cons (list (car keys) renamed) r))))))))
396  (let ((renames rename))
397    (if prefix?
398	(set! renames (add-prefix rename)))
399    (let loop ((renames renames))
400      (unless (null? renames)
401	(unless (= (length (car renames)) 2)
402	  (error "syntax-error: malformed rename spec in import clause:" rename))
403	(let ((org (caar renames))
404	      (renamed (cadar renames)))
405	  (hashtable-set! (library-table to) renamed
406			  (hashtable-ref (library-table from) org)))
407	(loop (cdr renames))))))
408
409(define (make-syntax name proc . user-defined?)
410  (if (null? user-defined?)
411      (vector 'type:syntax name proc #f)
412      (vector 'type:syntax name proc #t)))
413
414(define (syntax? s)
415  (and (vector? s)
416       (eq? (vector-ref s 0) 'type:syntax)))
417(define (syntax-name s)
418  (vector-ref s 1))
419(define (syntax-proc s)
420  (vector-ref s 2))
421(define (builtin-syntax? s)
422  (and (syntax? s)
423       (not (vector-ref s 3))))
424(define (user-defined-syntax? s)
425  (and (syntax? s)
426       (vector-ref s 3)))
427
428(define (call-syntax-handler s expr p1env)
429  (cond ((builtin-syntax? s)
430	 ((syntax-proc s) expr p1env))
431	(else
432	 (error 'call-syntax-handler "bug?"))))
433
434(define (unwrap-syntax form . only-global?)
435  (define rec
436    (lambda (form history)
437      (cond ((or (fixnum? form)
438		 (char? form)
439		 (boolean? form)) form)
440	    ((memq form history) form)
441	    ((pair? form)
442	     (let* ((newh (cons form history))
443		    (ca   (rec (car form) newh))
444		    (cd   (rec (cdr form) newh)))
445	       (if (and (eq? ca (car form))
446			(eq? cd (cdr form)))
447		   form
448		   (cons ca cd))))
449	    ((identifier? form)
450	     (id-name form))
451	    ((and (vector? form)
452		  (> (vector-length form) 1)
453		  (eq? (vector-ref form 0) '.closure))
454	     'closure)
455	    ((library? form)
456	     (library-name form))
457	    ((vector? form)
458	     (let ((len (vector-length form))
459		   (newh (cons form history)))
460	       (let loop ((i 0))
461		 (cond ((= i len) form)
462		       (else
463			(let* ((pe (vector-ref form i))
464			       (e (rec pe newh)))
465			  (cond ((eq? e pe)
466				 (loop (+ i 1)))
467				(else
468				 (let ((v (make-vector len #f)))
469				   (let vcopy ((j 0))
470				     (unless (= j i)
471				       (vector-set! v j (vector-ref form j))
472				       (vcopy (+ j 1))))
473				   (vector-set! v i e)
474				   (let vcopy ((j i))
475				     (unless (= j len)
476				       (vector-set! v j (vector-ref form j))
477				       (vcopy (+ j 1))))
478				   v)))))))))
479	    (else form))))
480  (if (null? only-global?)
481      (rec form '())
482      form))				; for scheme VM we don't do any thing
483
484(define (unwrap-syntax-with-reverse form) (unwrap-syntax form))
485
486(define wrap-syntax
487  (lambda (form p1env . opts)
488    (define env-lookup
489      (lambda (form p1env)
490	(let loop ((frames (vector-ref p1env 1)))
491	  (cond ((null? frames) frames)
492		(else
493		 (let lp ((vtmp (cdar frames)))
494		   (cond ((null? vtmp)
495			  (loop (cdr frames)))
496			 ((eq? form (caar vtmp)) frames)
497			 (else (lp (cdr vtmp))))))))))
498
499    (define rec
500      (lambda (form p1env seen partial?)
501	(cond ((null? form) form)
502	      ((pair? form) (cons (rec (car form) p1env seen partial?)
503				  (rec (cdr form) p1env seen partial?)))
504	      ((identifier? form) form)
505	      #;((closure? form) form)
506	      ((procedure? form) form)
507	      ((vector? form)
508	       (list->vector (rec (vector->list form) p1env seen partial?)))
509	      ((symbol? form)
510	       (let ((id (hashtable-ref seen form #f)))
511		 (if id
512		     id
513		     (let ((env (env-lookup form p1env)))
514		       (cond ((and (null? env)
515				   (not partial?))
516			      (set! id (make-identifier form
517							(vector-ref p1env 1)
518							(vector-ref p1env 0)))
519			      (hashtable-set! seen form id)
520			      id)
521			     ((not (null? env))
522			      (set! id (make-identifier form
523							env
524							(vector-ref p1env 0)))
525			      (hashtable-set! seen form id)
526			      id)
527			     (else form))))))
528	      (else form))))
529    (let ((seen (if (null? opts) (make-eq-hashtable) (car opts)))
530	  (partial? (if (or (null? opts)
531			    (null? (cdr opts)))
532			#f
533			(cadr opts))))
534      (rec form p1env seen partial?))))
535
536(define (make-macro name transformer data env . maybe-library)
537  (vector 'type:macro name transformer data env
538	  (if (null? maybe-library)
539	      #f
540	      (car maybe-library))))
541
542(define (variable-transformer? o)
543  (and (macro? o) (null? (macro-data o))))
544
545(define (macro-name m)
546  (vector-ref m 1))
547(define (macro-transformer m)
548  (vector-ref m 2))
549(define (macro-data m)
550  (vector-ref m 3))
551(define (macro-env m)
552  (vector-ref m 4))
553(define (macro-library m)
554  (vector-ref m 5))
555(define (macro? m)
556  (and (vector? m) (eq? (vector-ref m 0) 'type:macro)))
557(define (call-macro-expander macro expr p1env)
558  ((macro-transformer macro) macro expr p1env (macro-data macro)))
559(define (unbound) (if #f #f))
560
561(define (make-toplevel-closure cb)
562  (make-closure cb 0))
563
564;; for er-macro-transformer
565(define macro-transform
566  (lambda (self form p1env data)
567    (let ((expander (apply-proc data '()))
568	  (mac-env  (macro-env self))
569	  (uenv-save (current-usage-env))
570	  (menv-save (current-macro-env)))
571      (current-usage-env-set! p1env)
572      (current-macro-env-set! mac-env)
573      (if (macro? expander)
574	  (let ((r (apply-proc (macro-transformer expander) (list expander form p1env (macro-data expander)))))
575	    (current-usage-env-set! uenv-save)
576	    (current-macro-env-set! menv-save)
577	    r)
578	  (let ((r (apply-proc expander (list form))))
579	    (current-usage-env-set! uenv-save)
580	    (current-macro-env-set! menv-save)
581	    r))
582      #;(if (macro? expander)
583	  ((macro-transformer expander) expander form p1env (macro-data expander))
584	  (apply-proc expander (list (cons form p1env)))))))
585
586(define make-macro-transformer
587  (lambda (name proc env library)
588    (make-macro name macro-transform proc env library)))
589
590(define %internal-macro-expand
591  (lambda (expr p1env once?)
592    (let loop ((expr expr))
593      (cond ((null? expr) '())
594	    ((not (pair? expr)) expr)
595	    ;; ((xx ...) ...)
596	    ((pair? (car expr))
597	     (cons (loop (car expr))
598		   (loop (cdr expr))))
599	    (else
600	     (let ((g #f)
601		   (mac #f)
602		   (sym (car expr)))
603	       (cond ((identifier? sym)
604		      (set! g (find-binding (id-library sym)
605					    (id-name sym)
606					    #f)))
607		     ((symbol? sym)
608		      (set! g (find-binding (vector-ref p1env 0)
609					    sym
610					    #f))))
611	       (if (macro? g)
612		   (set! mac g)
613		   ;; try local macro
614		   (let ((g (p1env-lookup p1env sym SYNTAX)))
615		     (if (macro? g)
616			 (set! mac g))))
617	       (if mac
618		   ;; expand and continue
619		   (if once?
620		       (call-macro-expander mac expr p1env)
621		       (loop (call-macro-expander mac expr p1env)))
622		   ;; symbol
623		   (cons (car expr) (loop (cdr expr))))))))))
624
625
626(define (%map-cons l1 l2) (map cons l1 l2))
627;(define LEXICAL 0)
628;(define SYNTAX 1)
629;(define PATTERN 2)
630
631;; this needs to be in C++. I don't want to double manage these values.
632;;(define (pass3/let-frame-size) 2)
633(define (vm-frame-size) *frame-size*)
634
635;; also need to be c++
636;; code builder
637
638;; TODO: this must be cpp.
639;; ---> start
640;; actual code builder
641(define (make-array)
642  (vector '.array (make-vector 2) 0))
643(define (array-data a)
644  (vector-ref a 1))
645(define (array-data-set! a v)
646  (vector-set! a 1 v))
647(define (array-length a)
648  (vector-ref a 2))
649(define (array-length-set! a v)
650  (vector-set! a 2 v))
651
652(define array?
653  (lambda (a)
654    (and (vector? a)
655	 (eq? (vector-ref a 0) '.array))))
656(define array-data-length
657  (lambda (array)
658    (vector-length (array-data array))))
659(define array-data-copy
660  (lambda (src dst length)
661    (do ((i 0 (+ i 1)))
662	((>= i length) #f)
663      (vector-set! dst i (vector-ref src i)))))
664
665(define set-array-length!
666  (lambda (array length)
667    (array-length-set! array length)
668    (if (>= length (array-data-length array))
669      (let ((next-data (make-vector (* length 2))))
670	(array-data-copy (array-data array) next-data length)
671	(array-data-set! array next-data)))))
672
673(define array-push!
674  (lambda (array obj)
675    (let* ((data (array-data array))
676	   (length (array-length array)))
677      (vector-set! data length obj)
678      ;; extend array for next use
679      (set-array-length! array (+ length 1)))))
680
681(define array->list
682  (lambda (array)
683    (let ((data (array-data array))
684	  (length (array-length array)))
685      (let loop ((i 0)
686		 (ret '()))
687	(if (>= i length)
688	    (reverse ret)
689	    (loop (+ i 1) (cons (vector-ref data i) ret)))))))
690
691;; code builder
692;; code builder
693;; properties:
694;;   code   	 - for now just an array
695;;  <below this is for closure>
696;;   name        - closure name or #f
697;;   argc   	 - argument count
698;;   optional?   - #t it has optional arg, #f it has no optional arg
699;;   freec       - free variable count
700;;   maxStack    - estimated stack size
701;;   src         - src info
702;;  <below is for combine>
703;;   packet      - previous instruction data.
704;;   label-defs  - alist of (name . offset)
705;;   label-refs   - alist of (name . offset-to-fill)
706
707;; code-packet
708;;  insn - vm instruction
709;;  type - packet type
710;;  arg0 - instruction value
711;;  arg1 - instruction value
712;;  obj  - object
713(define-constant EMPTY 0)
714(define-constant ARGUMENT0 1)
715(define-constant ARGUMENT1 2)
716
717(define undef (if #f #f))
718(define (make-code-packet)
719  (vector -1 EMPTY 0 0 undef))
720
721(define (init-packet packet insn type arg0 arg1 o)
722  (when (or (null? arg0) (null? arg1))
723    (raise 'error))
724  (vector-set! packet 0 insn)
725  (vector-set! packet 1 type)
726  (vector-set! packet 2 arg0)
727  (vector-set! packet 3 arg1)
728  (vector-set! packet 4 o)
729  packet)
730
731(define (packet-insn packet) (vector-ref packet 0))
732(define (packet-insn-set! packet insn) (vector-set! packet 0 insn))
733(define (packet-type packet) (vector-ref packet 1))
734(define (packet-type-set! packet type) (vector-set! packet 1 type))
735(define (packet-arg0 packet) (vector-ref packet 2))
736(define (packet-arg0-set! packet o) (vector-set! packet 2 o))
737(define (packet-arg1 packet) (vector-ref packet 3))
738(define (packet-arg1-set! packet o) (vector-set! packet 3 o))
739(define (packet-obj packet) (vector-ref packet 4))
740(define (packet-obj-set! packet o) (vector-set! packet 4 o))
741
742(define (make-code-builder)
743  (vector '.code-builder (make-array) #f 0 #f 0 0 '()
744          (make-code-packet) '() '()))
745(define (code-builder-code cb)
746  (vector-ref cb 1))
747(define (code-builder-code-set! cb o)
748  (array-data-set! (vector-ref cb 1) o)
749  (array-length-set! (vector-ref cb 1) (vector-length o)))
750(define (code-builder-name cb) (vector-ref cb 2))
751(define (code-builder-name-set! cb argc) (vector-set! cb 2 argc))
752(define (code-builder-argc cb) (vector-ref cb 3))
753(define (code-builder-argc-set! cb argc) (vector-set! cb 3 argc))
754(define (code-builder-optional? cb) (vector-ref cb 4))
755(define (code-builder-optional-set! cb o) (vector-set! cb 4 o))
756(define (code-builder-freec cb) (vector-ref cb 5))
757(define (code-builder-freec-set! cb o) (vector-set! cb 5 o))
758(define (code-builder-maxstack cb) (vector-ref cb 6))
759(define (code-builder-maxstack-set! cb o) (vector-set! cb 6 o))
760(define (code-builder-src cb) (vector-ref cb 7))
761(define (code-builder-src-set! cb o) (vector-set! cb 7 o))
762(define (code-builder-add-src cb src)
763  (let ((index (array-length (code-builder-code cb)))
764        (old-src (code-builder-src cb)))
765    (code-builder-src-set! cb (append old-src (list (cons index src))))))
766(define (code-builder-packet cb) (vector-ref cb 8))
767(define (code-builder-packet-set! cb o) (vector-set! cb 8 o))
768(define (code-builder-label-defs cb) (vector-ref cb 9))
769(define (code-builder-label-defs-set! cb l) (vector-set! cb 9 l))
770(define (code-builder-label-refs cb) (vector-ref cb 10))
771(define (code-builder-label-refs-set! cb l) (vector-set! cb 10 l))
772
773(define (code-builder? cb)
774  (and (vector? cb)
775       (eq? (vector-ref cb 0) '.code-builder)))
776
777(define (label? l)
778  (and (vector? l)
779       (> (vector-length l) 0)
780       (eqv? (vector-ref l 0) 11 #;$LABEL
781             )))
782
783(define (cb-flush cb)
784  (if (= (packet-type (code-builder-packet cb)) EMPTY)
785      #t
786      (let ((insn (merge-insn2 (packet-insn (code-builder-packet cb))
787			       (packet-arg0 (code-builder-packet cb))
788			       (packet-arg1 (code-builder-packet cb)))))
789	(cond ((= (packet-type (code-builder-packet cb)) ARGUMENT0)
790	       (array-push! (code-builder-code cb) insn))
791	      ((= (packet-type (code-builder-packet cb)) ARGUMENT1)
792	       (let ((obj (packet-obj (code-builder-packet cb))))
793		 (array-push! (code-builder-code cb) insn)
794		 (if (label? obj)
795		     (begin
796		       (code-builder-label-refs-set!
797                        cb
798                        (acons obj
799                               (array-length (code-builder-code cb))
800                               (code-builder-label-refs cb)))
801		       (array-push! (code-builder-code cb) 0)) ; dummy
802		     (array-push! (code-builder-code cb) obj)))))
803	(code-builder-packet-set! cb (make-code-packet))
804	#;(packet-type-set! (code-builder-packet cb) EMPTY)
805        )))
806
807
808(define (cb-put cb packet)
809  (cond ((= (packet-type packet) ARGUMENT0)
810	 (combine-insn-arg0 cb packet))
811	((= (packet-type packet) ARGUMENT1)
812	 (combine-insn-arg1 cb packet))
813	((= (packet-type packet) ARGUMENT2)
814	 (combine-insn-arg2 cb packet))
815	(else (error 'cb-put "[internal] code-builder failed to emit code."))))
816
817(define (combine-insn-arg0 cb packet)
818  (cond ((= (packet-insn packet) PUSH)
819	 (cond ((= (packet-insn (code-builder-packet cb)) LREF)
820		(packet-insn-set! (code-builder-packet cb) LREF_PUSH))
821	       ((= (packet-insn (code-builder-packet cb)) FREF)
822		(packet-insn-set! (code-builder-packet cb) FREF_PUSH))
823	       ((= (packet-insn (code-builder-packet cb)) GREF)
824		(packet-insn-set! (code-builder-packet cb) GREF_PUSH))
825	       ((= (packet-insn (code-builder-packet cb)) CONST)
826		(packet-insn-set! (code-builder-packet cb) CONST_PUSH))
827	       ((= (packet-insn (code-builder-packet cb)) CONSTI)
828		(packet-insn-set! (code-builder-packet cb) CONSTI_PUSH))
829	       ((= (packet-insn (code-builder-packet cb)) CAR)
830		(packet-insn-set! (code-builder-packet cb) CAR_PUSH))
831	       ((= (packet-insn (code-builder-packet cb)) CDR)
832		(packet-insn-set! (code-builder-packet cb) CDR_PUSH))
833	       ((= (packet-insn (code-builder-packet cb)) CONS)
834		(packet-insn-set! (code-builder-packet cb) CONS_PUSH))
835	       ((= (packet-insn (code-builder-packet cb)) LREF_CAR)
836		(packet-insn-set! (code-builder-packet cb) LREF_CAR_PUSH))
837	       ((= (packet-insn (code-builder-packet cb)) FREF_CAR)
838		(packet-insn-set! (code-builder-packet cb) FREF_CAR_PUSH))
839	       ((= (packet-insn (code-builder-packet cb)) GREF_CAR)
840		(packet-insn-set! (code-builder-packet cb) GREF_CAR_PUSH))
841	       ((= (packet-insn (code-builder-packet cb)) LREF_CDR)
842		(packet-insn-set! (code-builder-packet cb) LREF_CDR_PUSH))
843	       ((= (packet-insn (code-builder-packet cb)) FREF_CDR)
844		(packet-insn-set! (code-builder-packet cb) FREF_CDR_PUSH))
845	       ((= (packet-insn (code-builder-packet cb)) GREF_CDR)
846		(packet-insn-set! (code-builder-packet cb) GREF_CDR_PUSH))
847	       (else
848		(cb-flush cb)
849		(code-builder-packet-set! cb packet))))
850	((= (packet-insn packet) RET)
851	 (cond ((= (packet-insn (code-builder-packet cb)) CONST)
852		(packet-insn-set! (code-builder-packet cb) CONST_RET))
853	       (else
854		(cb-flush cb)
855		(code-builder-packet-set! cb packet))))
856	((= (packet-insn packet) CAR)
857	 (cond ((= (packet-insn (code-builder-packet cb)) LREF)
858		(packet-insn-set! (code-builder-packet cb) LREF_CAR))
859	       ((= (packet-insn (code-builder-packet cb)) FREF)
860		(packet-insn-set! (code-builder-packet cb) FREF_CAR))
861	       ((= (packet-insn (code-builder-packet cb)) GREF)
862		(packet-insn-set! (code-builder-packet cb) GREF_CAR))
863	       ((= (packet-insn (code-builder-packet cb)) CAR)
864		(packet-insn-set! (code-builder-packet cb) CAAR))
865	       ((= (packet-insn (code-builder-packet cb)) CDR)
866		(packet-insn-set! (code-builder-packet cb) CADR))
867	       (else
868		(cb-flush cb)
869		(code-builder-packet-set! cb packet))))
870	((= (packet-insn packet) CDR)
871	 (cond ((= (packet-insn (code-builder-packet cb)) LREF)
872		(packet-insn-set! (code-builder-packet cb) LREF_CDR))
873	       ((= (packet-insn (code-builder-packet cb)) FREF)
874		(packet-insn-set! (code-builder-packet cb) FREF_CDR))
875	       ((= (packet-insn (code-builder-packet cb)) GREF)
876		(packet-insn-set! (code-builder-packet cb) GREF_CDR))
877	       ((= (packet-insn (code-builder-packet cb)) CAR)
878		(packet-insn-set! (code-builder-packet cb) CDAR))
879	       ((= (packet-insn (code-builder-packet cb)) CDR)
880		(packet-insn-set! (code-builder-packet cb) CDDR))
881	       (else
882		(cb-flush cb)
883		(code-builder-packet-set! cb packet))))
884	((= (packet-insn packet) UNDEF)
885	 ;; i don't want undef undef undef thing.
886	 (cond ((= (packet-insn (code-builder-packet cb)) UNDEF)
887		#t)
888	       (else
889		(cb-flush cb)
890		(code-builder-packet-set! cb packet))))
891	((= (packet-insn packet) CALL)
892	 (cond ((= (packet-insn (code-builder-packet cb)) GREF)
893		(packet-insn-set! (code-builder-packet cb) GREF_CALL)
894		(packet-type-set! (code-builder-packet cb) ARGUMENT1)
895		(packet-arg0-set! (code-builder-packet cb) (packet-arg0 packet)))
896	       (else
897		(cb-flush cb)
898		(code-builder-packet-set! cb packet))))
899	((= (packet-insn packet) TAIL_CALL)
900	 (cond ((= (packet-insn (code-builder-packet cb)) GREF)
901		(packet-insn-set! (code-builder-packet cb) GREF_TAIL_CALL)
902		(packet-type-set! (code-builder-packet cb) ARGUMENT1)
903		(packet-arg0-set! (code-builder-packet cb) (packet-arg0 packet)))
904	       (else
905		(cb-flush cb)
906		(code-builder-packet-set! cb packet))))
907	(else
908	 (cb-flush cb)
909	 (code-builder-packet-set! cb packet))))
910
911(define (combine-insn-arg1 cb packet)
912  (cond ((= (packet-insn packet) CONST)
913	 (let ((obj (packet-obj packet)))
914	   (cond ((and (integer? obj)
915		       (exact? obj)
916		       (<= #x-7ffff obj #x7ffff))
917		  (cb-flush cb)
918		  (packet-insn-set! packet CONSTI)
919		  (packet-type-set! packet ARGUMENT0)
920		  (packet-arg0-set! packet obj)
921		  (code-builder-packet-set! cb packet))
922		 (else
923		  (cb-flush cb)
924		  (code-builder-packet-set! cb packet)))))
925	#;((= (packet-insn packet) JUMP)
926	 (cond ((= (packet-insn (code-builder-packet cb)) SHIFTJ)
927		(packet-insn-set! (code-builder-packet cb) SHIFTJ_JUMP)
928		(packet-obj-set!  (code-builder-packet cb) (packet-obj packet)))
929	       (else
930		(cb-flush cb)
931		(code-builder-packet-set! cb packet))))
932	(else
933	 (cb-flush cb)
934	 (code-builder-packet-set! cb packet))))
935
936;; insn value map
937;; mmmmmmmm mmmmnnnn nnnnnnnn iiiiiiii
938;; m = arg2 (if it's required)
939;; n = arg1
940;; i = instruction
941;; insn must be under 255 (1 byte)
942(define (merge-insn1 insn arg1)
943  (bitwise-ior insn (bitwise-arithmetic-shift-left arg1 8)))
944
945;; arg1 and arg2 must be under 12 bit
946;; but on scheme vm, i'm not gonna check it
947(define (merge-insn2 insn arg1 arg2)
948  (bitwise-ior insn
949	       (bitwise-ior (bitwise-arithmetic-shift-left arg1 8)
950			    (bitwise-arithmetic-shift-left arg2 20))))
951
952(define (get-insn-value insn num index)
953  (cond ((= num 1)
954	 (bitwise-arithmetic-shift insn -8))
955	((= num 2)
956	 (cond ((= index 0)
957		(bitwise-and (bitwise-arithmetic-shift insn -8) #xfff))
958	       ((= index 1)
959		(bitwise-arithmetic-shift insn -20))))))
960
961(define (get-insn insn)
962  (bitwise-and insn #xff))
963
964;(merge-insn2 insn arg0 arg1)
965;; only insn values
966(define (cb-emit2! cb insn arg0 arg1)
967  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 arg1 undef)))
968(define (cb-emit1! cb insn arg0)
969  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 0 undef)))
970(define (cb-emit0! cb insn)
971  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 0 0 undef)))
972
973;; insn value with src info
974(define (cb-emit2i! cb insn arg0 arg1 src)
975  (code-builder-add-src cb src)
976  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 arg1 undef)))
977(define (cb-emit1i! cb insn arg0 src)
978  (code-builder-add-src cb src)
979  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 arg0 0 undef)))
980(define (cb-emit0i! cb insn src)
981  (code-builder-add-src cb src)
982  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT0 0 0 undef)))
983
984;; with object
985(define (cb-emit0o! cb insn o)
986  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 0 0 o)))
987(define (cb-emit0oi! cb insn o src)
988  (code-builder-add-src cb src)
989  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 0 0 o)))
990(define (cb-emit1oi! cb insn arg0 o src)
991  (code-builder-add-src cb src)
992  (cb-put cb (init-packet (make-code-packet) insn ARGUMENT1 arg0 0 o)))
993
994(define cb-label-set!
995  (lambda (cb label)
996    (cb-flush cb)
997    (code-builder-label-defs-set! cb
998				  (acons label (array-length (code-builder-code cb))
999					 (code-builder-label-defs cb)))))
1000
1001(define (cb-emit-closure! cb insn lambda-cb name argc opt? freec max-stack src)
1002  (code-builder-name-set! lambda-cb name)
1003  (code-builder-argc-set! lambda-cb argc)
1004  (code-builder-optional-set! lambda-cb opt?)
1005  (code-builder-freec-set! lambda-cb freec)
1006  (code-builder-maxstack-set! lambda-cb max-stack)
1007  (code-builder-add-src lambda-cb src)
1008  (cb-flush lambda-cb)
1009  (cb-emit0o! cb insn lambda-cb))
1010
1011;; this needs to be moved to C++
1012(define (code-builder-finish-builder cb last)
1013  (define (builder-label-def label-defs label)
1014    (cond ((assq label label-defs)
1015	   => cdr)
1016	  (else
1017	   (error 'builder-label-def "a label was refered but not defined.")
1018	   -1)))
1019
1020  (define (rec cb)
1021    (let* ((size (array-length (code-builder-code cb)))
1022	   (code (array-data   (code-builder-code cb)))
1023	   (label-defs (code-builder-label-defs cb))
1024	   (label-refs (code-builder-label-refs cb))
1025	   (v (make-vector size NOP)))
1026      (for-each (lambda (l)
1027		  (let ((dest (builder-label-def label-defs (car l)))
1028			(operand (cdr l)))
1029		    (vector-set! code operand (- dest operand))))
1030		label-refs)
1031      (let loop ((i 0))
1032	(if (= i size)
1033	    (begin
1034	      (array-length-set! (code-builder-code cb) size)
1035	      (array-data-set! (code-builder-code cb) v))
1036	    (let ((o (vector-ref code i)))
1037	      (vector-set! v i o)
1038	      (if (code-builder? (vector-ref code i))
1039		  (rec (vector-ref code i)))
1040	      (loop (+ i 1)))))))
1041  (unless (= last NOP)
1042    (cb-emit0! cb last))
1043  (cb-flush cb)
1044  (rec cb)
1045  cb)
1046;;;; end of file
1047;; Local Variables:
1048;; coding: utf-8-unix
1049;; End:
1050