Commit 96852676 authored by Erick Gallesio's avatar Erick Gallesio

New peephole optimizations

parent c56d2dab
2006-09-15 Erick Gallesio <eg@essi.fr>
* lib/peephole.stk: New peephole optimizations
* src/vm.c:
* lib/compiler.stk (compile-primitive-call): Better optimisation
on simple +, -, *, / operations.
2006-09-12 Erick Gallesio <eg@essi.fr>
* src/port.c: Added READ-BYTE and WRITE-BYTE
......
;;;;
;;;; assembler.stk -- Assember stuff
;;;;
;;;; Copyright 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 23-Aug-2005 08:49 (eg)
;;;; Last file update: 14-Sep-2006 14:44 (eg)
;;;;
;;;
......@@ -129,9 +129,11 @@
(IN-APPLY 2)
(MAKE-EXPANDER 1)
(SET-CUR-MOD 0)
(UNUSED-1 0)
(UNUSED-2 0)
;; The following instructions are not generated by the compiler
;; but by the peephole optimizer
(FALSE-PUSH 0) ;; peephole: IM-FALSE + PUSH
......@@ -145,8 +147,9 @@
(INT-PUSH 1) ;; peephole: SMALL-INT + PUSH
(CONSTANT-PUSH 1) ;; peephole: CONSTANT + PUSH
(GREF-INVOKE 2) ;; peephole: GLBAL_REF + INVOKE
(GREF-INVOKE 2) ;; peephole: GLOBAL_REF + INVOKE
(UGREF-INVOKE 2) ;; Never produced by the compiler
(IN-NUMDIFF 0) ;; peephole: IN-NUMEQ + NOT
(IN-NOT-EQ 0) ;; peephole: IN-EQ + NOT
(IN-NOT-EQV 0) ;; peephole: IN-EQV + NOT
......@@ -163,6 +166,42 @@
(JUMP-NOT-EQV 1) ;; peephole: IN-EQV + JUMP-FALSE
(JUMP-NOT-EQUAL 1) ;; peephole: IN-EQUAL + JUMP-FALSE
(LOCAL-REF0-PUSH 0) ;; peephole: LOCAL-REF0 + PUSH
(LOCAL-REF1-PUSH 0) ;; peephole: LOCAL-REF1 + PUSH
(LOCAL-REF2-PUSH 0) ;; peephole: LOCAL-REF2 + PUSH
(LOCAL-REF3-PUSH 0) ;; peephole: LOCAL-REF3 + PUSH
(LOCAL-REF4-PUSH 0) ;; peephole: LOCAL-REF4 + PUSH
(GLOBAL-REF-PUSH 1) ;; peephole: GLOBAL-REF + PUSH
(UGLOBAL-REF-PUSH 1) ;; Never produced by the compiler
(GREF-TAIL-INVOKE 2) ;; peephole: PUSH + GLOBAL_REF + INVOKE
(UGREF-TAIL-INVOKE 2) ;; Never produced by the compiler
(PUSH-PREPARE-CALL 0) ;; PUSH + PREPARE-CALL
(IN-SINT-ADD2 1)
(IN-SINT-SUB2 1)
(IN-SINT-MUL2 1)
(IN-SINT-DIV2 1)
;; To allow easy evolution without recompiling everything,
;; we declare fake instructions.
(UNUSED-3 0)
(UNUSED-4 0)
(UNUSED-5 0)
(UNUSED-6 0)
(UNUSED-7 0)
(UNUSED-8 0)
(UNUSED-9 0)
(UNUSED-10 0)
(UNUSED-11 0)
(UNUSED-12 0)
))))
;;;;
......
;;;;
;;;; c o m p i l e r . s t k -- STklos Compiler
;;;;
;;;; Copyright 2000-2005 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; Copyright 2000-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 27-Dec-2005 20:27 (eg)
;;;; Last file update: 15-Sep-2006 11:18 (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* '(+ - * / = <))
......@@ -89,10 +89,15 @@
(set! *code-constants* (append! *code-constants* x)))
(- (length *code-constants*) (length x))))
(define compile-constant
(define small-integer-constant?
(let ((min-int (- (expt 2 15)))
(max-int (- (expt 2 15) 1)))
(lambda (v env tail?)
(lambda (v)
(and (integer? v)
(exact? v)
(<= min-int v max-int)))))
(define (compile-constant v env tail?)
(cond
((eq? v #t) (emit 'IM-TRUE))
((eq? v #f) (emit 'IM-FALSE))
......@@ -101,10 +106,8 @@
((eq? v 0) (emit 'IM-ZERO))
((eq? v 1) (emit 'IM-ONE))
((eq? v (void)) (emit 'IM-VOID))
((and (integer? v)
(exact? v)
(<= min-int v max-int)) (emit 'SMALL-INT v))
(else (emit 'CONSTANT (fetch-constant v)))))))
((small-integer-constant? v) (emit 'SMALL-INT v))
(else (emit 'CONSTANT (fetch-constant v)))))
#|
......@@ -777,7 +780,6 @@ doc>
(emit (if tail? 'TAIL-INVOKE 'INVOKE)
(length actuals)))
(define (can-be-inlined fct)
(or (memq fct *always-inlined*)
(memq fct *compiler-inline*)))
......@@ -803,6 +805,14 @@ doc>
(emit mnemo))
(compiler-error fct epair "2 arguments required (~A provided)"
len))))
(oper2 (lambda (mnemo a b)
(compile a env epair #f)
(emit mnemo b)))
(komp2 (lambda (mnemo a b)
(compile a env epair #f)
(emit 'PUSH)
(compile b env epair #f)
(emit mnemo)))
(comp3 (lambda (mnemo)
(if (= len 3)
(begin
......@@ -828,25 +838,68 @@ doc>
((void) (emit 'IM-VOID))
((+) (case len
((0) (emit 'IM-ZERO))
((2) (if (eq? (car actuals) 1)
(comp 'IN-INCR (cadr actuals))
(if (eq? (cadr actuals) 1)
(comp 'IN-INCR (car actuals))
(comp2 'IN-ADD2))))
((1) (compile (car actuals) env epair tail?))
((2) (let ((a (car actuals))
(b (cadr actuals)))
(cond
((and (number? a) (number? b))
(compile-constant (+ a b) env #f))
((small-integer-constant? a)
(oper2 'IN-SINT-ADD2 b a))
((small-integer-constant? b)
(oper2 'IN-SINT-ADD2 a b))
(else
(comp2 'IN-ADD2)))))
(else (compile-normal-call fct actuals len env epair #f))))
((-) (case len
((0) (compiler-error '- epair "needs at least one argument"))
((2) (if (eq? (cadr actuals) 1)
(comp 'IN-DECR (car actuals))
(comp2 'IN-SUB2)))
((1) (if (number? (car actuals))
(compile-constant (- (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-SUB2 b a))
((and (number? b)
(small-integer-constant? (- b)))
(oper2 'IN-SINT-ADD2 a (- b)))
(else
(comp2 'IN-SUB2)))))
(else (compile-normal-call fct actuals len env epair #f))))
((*) (case len
((0) (emit 'IM-ONE))
((2) (comp2 'IN-MUL2))
((1) (compile (car actuals) env epair tail?))
((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-MUL2 b a))
((small-integer-constant? 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"))
((2) (comp2 'IN-DIV2))
((1) (if (number? (car actuals))
(compile-constant (/ (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))
(else
(comp2 'IN-DIV2)))))
(else (compile-normal-call fct actuals len env epair #f))))
((= < > <= >=)
(case len
......
;;;;
;;;; peephole.stk -- Peephole Optimiser fro the STklos VM
;;;;
;;;; Copyright 2001-2003 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,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Mar-2001 20:32 (eg)
;;;; Last file update: 10-Feb-2003 17:41 (eg)
;;;; Last file update: 14-Sep-2006 14:41 (eg)
;;;;
; ======================================================================
......@@ -163,6 +163,34 @@
(replace-2-instr code (list 'GREF-INVOKE
(this-arg1 code)
(next-arg1 code))))
;; [GLOBAL-REF, TAIL-INVOKE] => GREF-TAIL(INVOKE
((and (eq? i1 'GLOBAL-REF) (eq? i2 'TAIL-INVOKE))
(replace-2-instr code (list 'GREF-TAIL-INVOKE
(this-arg1 code)
(next-arg1 code))))
;; [LOCAL-REFx, PUSH] => LOCAL-REFx-PUSH
((and (eq? i2 'PUSH) (memq i1 '(LOCAL-REF0 LOCAL-REF1
LOCAL-REF2 LOCAL-REF3
LOCAL-REF4)))
(replace-2-instr code
(list (case i1
((LOCAL-REF0) 'LOCAL-REF0-PUSH)
((LOCAL-REF1) 'LOCAL-REF1-PUSH)
((LOCAL-REF2) 'LOCAL-REF2-PUSH)
((LOCAL-REF3) 'LOCAL-REF3-PUSH)
((LOCAL-REF4) 'LOCAL-REF4-PUSH)))))
;; [GLOBAL-REF, PUSH] => GLOBAL-REF-PUSH
((and (eq? i1 'GLOBAL-REF) (eq? i2 'PUSH))
(replace-2-instr code (list 'GLOBAL-REF-PUSH
(this-arg1 code))))
;; [PUSH, PREPARE-CALL] => PUSH-PREPARE-CALL
((and (eq? i1 'PUSH) (eq? i2 'PREPARE-CALL))
(replace-2-instr code (list 'PUSH-PREPARE-CALL)))
(else ;; No optimization; goto next instruction
(set! code (cdr code))))))
;; Loop again on the same instruction
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 12-Sep-2006 15:26 (eg)
* Last file update: 13-Sep-2006 08:58 (eg)
*
*/
......@@ -404,7 +404,7 @@ DEFINE_PRIMITIVE("peek-char", peek_char, subr01, (SCM port))
* returns a character, this function returns an integer between 0and 255.
doc>
*/
DEFINE_PRIMITIVE("peek-byte", peek_char, subr01, (SCM port))
DEFINE_PRIMITIVE("peek-byte", peek_byte, subr01, (SCM port))
{
int c;
......
......@@ -103,8 +103,32 @@
# define JUMP_NOT_EQ 98
# define JUMP_NOT_EQV 99
# define JUMP_NOT_EQUAL 100
# define LOCAL_REF0_PUSH 101
# define LOCAL_REF1_PUSH 102
# define LOCAL_REF2_PUSH 103
# define LOCAL_REF3_PUSH 104
# define LOCAL_REF4_PUSH 105
# define GLOBAL_REF_PUSH 106
# define UGLOBAL_REF_PUSH 107
# define GREF_TAIL_INVOKE 108
# define UGREF_TAIL_INVOKE 109
# define PUSH_PREPARE_CALL 110
# define IN_SINT_ADD2 111
# define IN_SINT_SUB2 112
# define IN_SINT_MUL2 113
# define IN_SINT_DIV2 114
# define UNUSED_3 115
# define UNUSED_4 116
# define UNUSED_5 117
# define UNUSED_6 118
# define UNUSED_7 119
# define UNUSED_8 120
# define UNUSED_9 121
# define UNUSED_10 122
# define UNUSED_11 123
# define UNUSED_12 124
# define NB_VM_INSTR (JUMP_NOT_EQUAL +1)
# define NB_VM_INSTR (UNUSED_12 +1)
#endif
......@@ -212,6 +236,30 @@ static void *jump_table[] = {
&&lab_JUMP_NOT_EQ ,
&&lab_JUMP_NOT_EQV ,
&&lab_JUMP_NOT_EQUAL ,
&&lab_LOCAL_REF0_PUSH ,
&&lab_LOCAL_REF1_PUSH ,
&&lab_LOCAL_REF2_PUSH ,
&&lab_LOCAL_REF3_PUSH ,
&&lab_LOCAL_REF4_PUSH ,
&&lab_GLOBAL_REF_PUSH ,
&&lab_UGLOBAL_REF_PUSH ,
&&lab_GREF_TAIL_INVOKE ,
&&lab_UGREF_TAIL_INVOKE ,
&&lab_PUSH_PREPARE_CALL ,
&&lab_IN_SINT_ADD2 ,
&&lab_IN_SINT_SUB2 ,
&&lab_IN_SINT_MUL2 ,
&&lab_IN_SINT_DIV2 ,
&&lab_UNUSED_3 ,
&&lab_UNUSED_4 ,
&&lab_UNUSED_5 ,
&&lab_UNUSED_6 ,
&&lab_UNUSED_7 ,
&&lab_UNUSED_8 ,
&&lab_UNUSED_9 ,
&&lab_UNUSED_10 ,
&&lab_UNUSED_11 ,
&&lab_UNUSED_12 ,
NULL};
#endif
#undef DEFINE_JUMP_TABLE
......@@ -321,6 +369,30 @@ static char *name_table[] = {
"JUMP_NOT_EQ ",
"JUMP_NOT_EQV ",
"JUMP_NOT_EQUAL ",
"LOCAL_REF0_PUSH ",
"LOCAL_REF1_PUSH ",
"LOCAL_REF2_PUSH ",
"LOCAL_REF3_PUSH ",
"LOCAL_REF4_PUSH ",
"GLOBAL_REF_PUSH ",
"UGLOBAL_REF_PUSH ",
"GREF_TAIL_INVOKE ",
"UGREF_TAIL_INVOKE ",
"PUSH_PREPARE_CALL ",
"IN_SINT_ADD2 ",
"IN_SINT_SUB2 ",
"IN_SINT_MUL2 ",
"IN_SINT_DIV2 ",
"UNUSED_3 ",
"UNUSED_4 ",
"UNUSED_5 ",
"UNUSED_6 ",
"UNUSED_7 ",
"UNUSED_8 ",
"UNUSED_9 ",
"UNUSED_10 ",
"UNUSED_11 ",
"UNUSED_12 ",
NULL};
#endif
#undef DEFINE_NAME_TABLE
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 1-Mar-2000 19:51 (eg)
* Last file update: 4-Aug-2006 12:46 (eg)
* Last file update: 15-Sep-2006 11:19 (eg)
*/
// INLINER values
......@@ -801,17 +801,17 @@ CASE(IM_VOID) { vm->val = STk_void; NEXT1;}
CASE(SMALL_INT) { vm->val = MAKE_INT(fetch_next()); NEXT1;}
CASE(CONSTANT) { vm->val = fetch_const(); NEXT1;}
CASE(FALSE_PUSH) { push(vm->val = STk_false); NEXT1;}
CASE(TRUE_PUSH) { push(vm->val = STk_true); NEXT1;}
CASE(NIL_PUSH) { push(vm->val = STk_nil); NEXT1;}
CASE(MINUS1_PUSH) { push(vm->val = MAKE_INT(-1)); NEXT1;}
CASE(ZERO_PUSH) { push(vm->val = MAKE_INT( 0)); NEXT1;}
CASE(ONE_PUSH) { push(vm->val = MAKE_INT(+1)); NEXT1;}
CASE(VOID_PUSH) { push(vm->val = STk_void); NEXT1;}
CASE(FALSE_PUSH) { push(STk_false); NEXT;}
CASE(TRUE_PUSH) { push(STk_true); NEXT;}
CASE(NIL_PUSH) { push(STk_nil); NEXT;}
CASE(MINUS1_PUSH) { push(MAKE_INT(-1)); NEXT;}
CASE(ZERO_PUSH) { push(MAKE_INT( 0)); NEXT;}
CASE(ONE_PUSH) { push(MAKE_INT(+1)); NEXT;}
CASE(VOID_PUSH) { push(STk_void); NEXT;}
CASE(INT_PUSH) { push(vm->val=MAKE_INT(fetch_next())) ; NEXT1; }
CASE(CONSTANT_PUSH) { push(vm->val=fetch_const()); NEXT1; }
CASE(INT_PUSH) { push(MAKE_INT(fetch_next())) ; NEXT; }
CASE(CONSTANT_PUSH) { push(fetch_const()); NEXT; }
CASE(GLOBAL_REF) {
......@@ -829,6 +829,22 @@ CASE(UGLOBAL_REF) {
NEXT1;
}
CASE(GLOBAL_REF_PUSH) {
SCM ref;
push(STk_lookup(fetch_const(), vm->env, &ref, TRUE));
/* patch the code for optimize next accesses */
vm->pc[-2] = UGLOBAL_REF_PUSH;
vm->pc[-1] = add_global(&CDR(ref));
NEXT;
}
CASE(UGLOBAL_REF_PUSH) {
/* Never produced by compiler */
push(fetch_global());
NEXT;
}
CASE(GREF_INVOKE) {
SCM ref;
......@@ -850,6 +866,29 @@ CASE(UGREF_INVOKE) { /* Never produced by compiler */
tailp = FALSE; goto FUNCALL;
}
CASE(GREF_TAIL_INVOKE) {
SCM ref;
vm->val = STk_lookup(fetch_const(), vm->env, &ref, TRUE);
nargs = fetch_next();
/* patch the code for optimize next accesses (pc[-1] is already equal to nargs)*/
vm->pc[-3] = UGREF_TAIL_INVOKE;
vm->pc[-2] = add_global(&CDR(ref));
/* and now invoke */
tailp=TRUE; goto FUNCALL;
}
CASE(UGREF_TAIL_INVOKE) { /* Never produced by compiler */
vm->val = fetch_global();
nargs = fetch_next();
/* invoke */
tailp = TRUE; goto FUNCALL;
}
CASE(LOCAL_REF0) { vm->val = FRAME_LOCAL(vm->env, 0); NEXT1;}
CASE(LOCAL_REF1) { vm->val = FRAME_LOCAL(vm->env, 1); NEXT1;}
CASE(LOCAL_REF2) { vm->val = FRAME_LOCAL(vm->env, 2); NEXT1;}
......@@ -868,6 +907,11 @@ CASE(DEEP_LOCAL_REF) {
NEXT1;
}
CASE(LOCAL_REF0_PUSH) {push(FRAME_LOCAL(vm->env, 0)); NEXT;}
CASE(LOCAL_REF1_PUSH) {push(FRAME_LOCAL(vm->env, 1)); NEXT;}
CASE(LOCAL_REF2_PUSH) {push(FRAME_LOCAL(vm->env, 2)); NEXT;}
CASE(LOCAL_REF3_PUSH) {push(FRAME_LOCAL(vm->env, 3)); NEXT;}
CASE(LOCAL_REF4_PUSH) {push(FRAME_LOCAL(vm->env, 4)); NEXT;}
CASE(GLOBAL_SET) {
SCM ref;
......@@ -890,6 +934,7 @@ CASE(LOCAL_SET3) { FRAME_LOCAL(vm->env, 3) = vm->val; NEXT0;}
CASE(LOCAL_SET4) { FRAME_LOCAL(vm->env, 4) = vm->val; NEXT0;}
CASE(LOCAL_SET) { FRAME_LOCAL(vm->env,fetch_next()) = vm->val; NEXT0;}
CASE(DEEP_LOCAL_SET) {
int level, info = fetch_next();
SCM e = vm->env;
......@@ -997,6 +1042,8 @@ CASE(TAIL_INVOKE) {
goto FUNCALL;
}
CASE(PUSH_PREPARE_CALL) {push(vm->val); PREP_CALL(); NEXT; }
CASE(ENTER_LET_STAR) {
nargs = fetch_next();
......@@ -1109,12 +1156,21 @@ CASE(END_OF_CODE) {
return;
}
CASE(UNUSED_1)
CASE(UNUSED_2)
CASE(UNUSED_3)
CASE(UNUSED_4)
CASE(UNUSED_5)
CASE(UNUSED_6)
CASE(UNUSED_7)
CASE(UNUSED_8)
CASE(UNUSED_9)
CASE(UNUSED_10)
CASE(UNUSED_11)
CASE(UNUSED_12) {
CASE(UNUSED_1) {
}
CASE(UNUSED_2) {
}
......@@ -1135,6 +1191,16 @@ CASE(IN_MUL2) { REG_CALL_PRIM(multiplication);
CASE(IN_DIV2) { REG_CALL_PRIM(division);
vm->val = STk_div2(pop(), vm->val); NEXT1;}
CASE(IN_SINT_ADD2) { REG_CALL_PRIM(plus);
vm->val = STk_add2(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_SUB2) { REG_CALL_PRIM(difference);
vm->val = STk_sub2(MAKE_INT(fetch_next()), vm->val); NEXT1;}
CASE(IN_SINT_MUL2) { REG_CALL_PRIM(multiplication);
vm->val = STk_mul2(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_SINT_DIV2) { REG_CALL_PRIM(division);
vm->val = STk_div2(vm->val, MAKE_INT(fetch_next())); NEXT1;}
CASE(IN_NUMEQ) { REG_CALL_PRIM(numeq);
vm->val = MAKE_BOOLEAN(STk_numeq2(pop(), vm->val)); NEXT1;}
CASE(IN_NUMDIFF){ REG_CALL_PRIM(numeq);
......
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