Commit ee57c5b4 authored by Erick Gallesio's avatar Erick Gallesio

Added compilation to C

parent 6285c8cc
2006-09-26 Erick Gallesio <eg@essi.fr>
* utils/stklos-compile: Added the possibility to compile
byte-codes to a C file.
2006-09-22 Erick Gallesio <eg@essi.fr>
* src/sport.c (Sgetc): Bug fix: the character #xff was read as
......
......@@ -33,9 +33,13 @@ Output the compiled code in the given file instead of
.I a.out.
.IP "--case-sensitive, -c"
Symbols are case sensitive
.IP "--C-code, -C"
Produce the byte-code in a C file instead of a ".ostk" file.
.IP "--line-info, -l"
Generate line informations to ease debugging (incurs a small
performance penalty).
.IP "--no-time"
Do not display the compilation time
.IP "--help | -h | -?"
Show help.
......
......@@ -2,7 +2,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 11-Sep-2006 17:24 (eg)
# Last file update: 26-Sep-2006 19:51 (eg)
SUBDIRS = Match.d SILex.d Lalr.d @LURCDIR@
......@@ -149,6 +149,9 @@ $(DOCDB): $(scheme_SRCS) $(scheme_BOOT)
clean:
/bin/rm -f $(scheme_OBJS)
@for i in $(SUBDIRS) ;do \
(cd $$i; make clean)\
done
distclean: clean
true
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 11-Sep-2006 17:24 (eg)
# Last file update: 26-Sep-2006 19:51 (eg)
srcdir = @srcdir@
top_srcdir = @top_srcdir@
......@@ -656,6 +656,9 @@ $(DOCDB): $(scheme_SRCS) $(scheme_BOOT)
clean:
/bin/rm -f $(scheme_OBJS)
@for i in $(SUBDIRS) ;do \
(cd $$i; make clean)\
done
distclean: clean
true
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 18-Sep-2006 11:25 (eg)
;;;; Last file update: 26-Sep-2006 19:36 (eg)
;;;;
;;;
......@@ -187,6 +187,12 @@
(PUSH-GREF-TAIL-INV 2) ;; PUSH + GLOBAL-REF + TAIL-INVOKE
(PUSH-UGREF-TAIL-INV 2) ;; Never produced by the compiler
(UNUSED-20 0)
(UNUSED-19 0)
(UNUSED-18 0)
(UNUSED-17 0)
(UNUSED-16 0)
(UNUSED-15 0)
(UNUSED-14 0)
(UNUSED-13 0)
(UNUSED-12 0)
......
;;;;
;;;
;;;; c o m p i l e r . s t k -- STklos Compiler
;;;;
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 15-Sep-2006 16:05 (eg)
;;;; Last file update: 26-Sep-2006 22:03 (eg)
;;;;
;;(define-module new-compiler
......@@ -29,7 +29,7 @@
(define *compiler-port* #f)
(define *compiler-options* (list 'warn-use-undef))
(define *compiler-inline* '(+ ++ - * / = < <= > >= cons car cdr null? list not
(define *compiler-inline* '(+ - * / = < <= > >= cons car cdr null? list not
vector-ref vector-set! string-ref string-set!
eq? eqv? equal? void))
;(define *compiler-inline* '(+ - * / = <))
......@@ -880,24 +880,22 @@ doc>
((small-integer-constant? a)
(oper2 'IN-SINT-MUL2 b a))
((small-integer-constant? b)
(oper2 'IN-SINT-MUL2 a b))
(oper2 'IN-SINT-MUL2 a b))
(else
(comp2 'IN-MUL2)))))
(else (compile-normal-call fct actuals len env epair #f))))
((/) (case len
((0) (compiler-error '/ epair "needs at least one argument"))
((1) (if (number? (car actuals))
(compile-constant (/ (car actuals)) env epair #f)
(compile-constant (/ 1 (car actuals)) env epair #f)
(compile-normal-call fct actuals len env epair #f)))
((2) (let ((a (car actuals))
(b (cadr actuals)))
(cond
((and (number? a) (number? b))
(compile-constant (/ a b) env tail?))
((small-integer-constant? a)
(oper2 'IN-SINT-DIV2 b a))
((small-integer-constant? b)
(oper2 'IN-SINT-DIV2 a b))
(oper2 'IN-SINT-DIV2 a b))
(else
(comp2 'IN-DIV2)))))
(else (compile-normal-call fct actuals len env epair #f))))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 20:32 (eg)
;;;; Last file update: 22-Sep-2006 20:15 (eg)
;;;; Last file update: 26-Sep-2006 20:03 (eg)
;;;;
; ======================================================================
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 6-Aug-2006 22:09 (eg)
* Last file update: 26-Sep-2006 13:26 (eg)
*/
#ifndef STKLOS_H
......@@ -1174,6 +1174,7 @@ EXTERN_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void));
SCM STk_load_bcode_file(SCM f);
int STk_load_boot(char *s);
int STk_boot_from_C(void);
SCM STk_execute_C_bytecode(SCM consts, STk_instr *instr);
int STk_init_vm();
......
......@@ -119,22 +119,28 @@
# define PUSH_UGREF_INVOKE 114
# define PUSH_GREF_TAIL_INV 115
# define PUSH_UGREF_TAIL_INV 116
# define UNUSED_14 117
# define UNUSED_13 118
# define UNUSED_12 119
# define UNUSED_11 120
# define UNUSED_10 121
# define UNUSED_9 122
# define UNUSED_8 123
# define UNUSED_7 124
# define UNUSED_6 125
# define UNUSED_5 126
# define UNUSED_4 127
# define UNUSED_3 128
# define IN_SINT_ADD2 129
# define IN_SINT_SUB2 130
# define IN_SINT_MUL2 131
# define IN_SINT_DIV2 132
# define UNUSED_20 117
# define UNUSED_19 118
# define UNUSED_18 119
# define UNUSED_17 120
# define UNUSED_16 121
# define UNUSED_15 122
# define UNUSED_14 123
# define UNUSED_13 124
# define UNUSED_12 125
# define UNUSED_11 126
# define UNUSED_10 127
# define UNUSED_9 128
# define UNUSED_8 129
# define UNUSED_7 130
# define UNUSED_6 131
# define UNUSED_5 132
# define UNUSED_4 133
# define UNUSED_3 134
# define IN_SINT_ADD2 135
# define IN_SINT_SUB2 136
# define IN_SINT_MUL2 137
# define IN_SINT_DIV2 138
# define NB_VM_INSTR (IN_SINT_DIV2 +1)
#endif
......@@ -260,6 +266,12 @@ static void *jump_table[] = {
&&lab_PUSH_UGREF_INVOKE ,
&&lab_PUSH_GREF_TAIL_INV ,
&&lab_PUSH_UGREF_TAIL_INV ,
&&lab_UNUSED_20 ,
&&lab_UNUSED_19 ,
&&lab_UNUSED_18 ,
&&lab_UNUSED_17 ,
&&lab_UNUSED_16 ,
&&lab_UNUSED_15 ,
&&lab_UNUSED_14 ,
&&lab_UNUSED_13 ,
&&lab_UNUSED_12 ,
......@@ -401,6 +413,12 @@ static char *name_table[] = {
"PUSH_UGREF_INVOKE ",
"PUSH_GREF_TAIL_INV ",
"PUSH_UGREF_TAIL_INV ",
"UNUSED_20 ",
"UNUSED_19 ",
"UNUSED_18 ",
"UNUSED_17 ",
"UNUSED_16 ",
"UNUSED_15 ",
"UNUSED_14 ",
"UNUSED_13 ",
"UNUSED_12 ",
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 18-Sep-2006 11:27 (eg)
* Last file update: 26-Sep-2006 16:18 (eg)
*/
// INLINER values
......@@ -1056,7 +1056,7 @@ CASE(TAIL_INVOKE) {
goto FUNCALL;
}
CASE(PUSH_PREPARE_CALL) {push(vm->val); PREP_CALL(); NEXT; }
CASE(PUSH_PREPARE_CALL) {push(vm->val); PREP_CALL(); NEXT; }
CASE(ENTER_LET_STAR) {
nargs = fetch_next();
......@@ -1840,6 +1840,30 @@ int STk_boot_from_C(void)
system_has_booted = 1;
return 0;
}
SCM STk_execute_C_bytecode(SCM all_consts, STk_instr *instr)
{
SCM consts, *save_constants, save_env;
STk_instr *save_pc;
vm_thread_t *vm = STk_get_current_vm();
consts = STk_read(STk_open_C_string(all_consts), TRUE);
/* Save machine state */
save_pc = vm->pc; save_constants = vm->constants; save_env = vm->env;
/* Go */
vm->pc = instr;
vm->constants = VECTOR_DATA(consts);
vm->env = vm->current_module;
run_vm(vm);
/* restore machine state */
vm->pc = save_pc; vm->constants = save_constants, vm->env = save_env;
return STk_void;
}
#ifdef THREADS_LURC
SCM *STk_save_vm(void){
vm_thread_t *vm = STk_get_current_vm();
......
;;;;
;;;; stklos-compile.stk -- Call the stklos compiler
;;;;
;;;; Copyright © 2001-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2001-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,11 +21,89 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Dec-2001 18:12 (eg)
;;;; Last file update: 26-Apr-2005 11:22 (eg)
;;;; Last file update: 26-Sep-2006 17:42 (eg)
;;;;
(define *output* "a.out")
(define *c-code* #f)
;; ----------------------------------------------------------------------
;; convert-to-C ...
;; ----------------------------------------------------------------------
(define (convert-to-C src dst module-name)
(define (header in out)
(format out "/* -*- C -*-\n")
(format out " This file was automatically generated on ~A\n" (date))
(format out " This is a dump of the image in file ~A\n" (port-file-name in))
(format out " ***DO NOT EDIT BY HAND***\n*/\n")
(format out "#include <stklos.h>\n\n"))
(define (footer out name)
(format out "#ifdef MODULE_ENTRY\n")
(format out "MODULE_ENTRY_START(~S) {\n" name)
(format out " STk_execute_C_bytecode(__module_consts, __module_code);\n")
(format out "} MODULE_ENTRY_END\n")
(format out "#endif\n"))
(let ((in (open-input-file src))
(out (open-output-file dst)))
(read in)
(read in)
(let ((v (read in))
(str (open-output-string)))
(write v str)
(header in out)
(format out "static char* __module_consts = ~S;\n\n" (get-output-string str)))
(let ((sz (read in)))
(format out "static STk_instr __module_code [] = { \n")
(read-char in) ; To skip the newline after size
(dotimes (i sz)
(let* ((c1 (read-char in))
(c2 (read-char in)))
(format out
"~5f"
(string-append
"0x"
(number->string (bit-or (bit-shift (char->integer c1) 8)
(char->integer c2))
16)))
(when (< i (- sz 1))
(display ", " out))
(when (= (modulo i 10) 9)
(newline out))))
(display "};\n\n" out))
(footer out module-name)
(flush-output-port out)
(close-port out)))
;; ----------------------------------------------------------------------
;; compile-to-C-code ...
;; ----------------------------------------------------------------------
(define (compile-to-C-code file out)
(define (file-prefix str)
;; very approximate
(let ((x (string-split str ".")))
(if (= (length x) 2) (car x) str)))
(let ((tmp (temporary-file-name))
(name (file-prefix (basename file))))
(compile-to-bytecode file tmp)
(convert-to-C tmp out name)
(remove-file tmp)))
;; ----------------------------------------------------------------------
;; compile-to-bytecode ...
;; ----------------------------------------------------------------------
(define (compile-to-bytecode file out)
(compile-file file out)
(chmod out #o755))
;; ----------------------------------------------------------------------
;; main ...
;; ----------------------------------------------------------------------
(define (main args)
(parse-arguments args
"Usage: stklos-compile [options] file"
......@@ -35,6 +113,8 @@
(set! *output* file))
(("case-sensitive" :alternate "c" :help "Be case sensitive on symbols")
(read-case-sensitive #t))
(("C-code" :alternate "C" :help "Produce C code")
(set! *c-code* #t))
(("line-info" :alternate "l" :help "Insert line numbers in generated file")
(compiler:gen-line-number #t))
(("no-time" :help "Don't display compilation time")
......@@ -45,9 +125,10 @@
(else
(cond
((= (length other-arguments) 1)
(compile-file (car other-arguments) *output*)
(chmod *output* #o755)
(exit 0))
(if *c-code*
(compile-to-C-code (car other-arguments) *output*)
(compile-to-bytecode (car other-arguments) *output*))
(exit 0))
(else
(arg-usage (current-error-port))
(exit 1))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment