Commit 11c3b4aa authored by Erick Gallesio's avatar Erick Gallesio

Addind 3 new instructions (FAR mode)

parent 1ba1dc85
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 14-Mar-2001 13:49 (eg)
;;;; Last file update: 22-Feb-2007 19:51 (eg)
;;;; Last file update: 23-Feb-2007 16:29 (eg)
;;;;
;;;
......@@ -212,6 +212,22 @@
(IN-SINT-SUB2 1)
(IN-SINT-MUL2 1)
(IN-SINT-DIV2 1)
(UNUSED-29 0)
(UNUSED-28 0)
(UNUSED-27 0)
(UNUSED-26 0)
(UNUSED-25 0)
(UNUSED-24 0)
(UNUSED-23 0)
(UNUSED-22 0)
(UNUSED-21 0)
(UNUSED-20 0)
;; FAR instructions
(DEEP-LOC-REF-FAR 1)
(DEEP-LOC-SET-FAR 1)
(CREATE-CLOSURE-FAR 2)
))))
......@@ -232,7 +248,8 @@
JUMP-NUMGT JUMP-NUMGE
JUMP-NUMLT JUMP-NUMLE
JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL
CREATE-CLOSURE PUSH-HANDLER))))
CREATE-CLOSURE CREATE-CLOSURE-FAR
PUSH-HANDLER))))
(lambda (instr)
(memq instr instr-with-address))))
......@@ -242,6 +259,20 @@
(string-append m filler)))
(define (find-instruction-infos opcode)
(let Loop ((l INSTRUCTION-SET))
(cond
((null? l) (panic "Cannot decode ~S opcode" opcode))
((= (cadar l) opcode) (car l))
(else (Loop (cdr l))))))
(define (find-far-codeop opcode)
(let ((old-mnemo (car (find-instruction-infos opcode))))
(case old-mnemo
((CREATE-CLOSURE) opcode)
(else (panic "No FAR version of instruction ~S" old-mnemo)))))
;;;;======================================================================
;;;;
;;;; ASSEMBLE
......@@ -255,7 +286,6 @@
(let ((pc 0)
(labs '())
(code (peephole code)))
;;
;; Pass 1
;;
......@@ -267,15 +297,12 @@
;; We have an instruction
(let* ((token (car x))
(info (info-opcode token)))
;//(format (current-error-port) "~S: ~S" pc x)
;; Replace the op-code in (car x) by its code
(set-car! x (car info))
;//(format (current-error-port) "==> ~S\n" x)
;; Compute new PC
(set! pc (+ pc (length x))))))
code)
(eprintf "A l'issue de la passe 1 pc=~S labs=~S\n" pc labs)
;(eprintf "A l'issue de la passe 1 pc=~S labs=~S\n" pc labs)
;;
;; Pass2
......@@ -296,30 +323,29 @@
;; If this instruction has a parameter which is an label,
;; replace it with the offset to the destination
(when (use-address? instr)
;;// (format #t "~S ~S ~S\n"
;;// (cdr (assq param1 labs))
;;// pos
;;// (- (cdr (assq param1 labs)) pos 2))
(set! param1 (- (cdr (assq param1 labs)) pos 2))
;// (set! param1 `((etiq ,param1)
;// (real ,(cdr (assq param1 labs)))
;// (pos = ,pos)
;// (offset ,(- (cdr (assq param1 labs)) pos 2))))
)
(set! param1 (- (cdr (assq param1 labs)) pos 2)))
;; For instructions using big constants use their FAR version
(unless (small-integer-constant? param1)
(let ((new (find-far-codeop instr)))
(eprintf "FAR ~S ~S ~S\n"
(car (find-instruction-infos instr))
new
param1)))
;; Store the (eventually new) value of param1 in code array
(vector-set! vect (+ pos 1) param1)))
;; Place (eventually) the second parameter in the code vector
(when (> len 2)
(unless (small-integer-constant? (caddr x))
(panic "Instruction with a big constant as second parameter ~S"
x))
(vector-set! vect (+ pos 2) (caddr x)))
(when (> len 3)
(panic "Instruction with more than 2 parameters ~S" x))
(set! pos (+ pos len))))
; (eprintf "A LA FIN pos=~S vector=~S\n" pos vect)
)
(set! pos (+ pos len)))))
code)
(eprintf "A LA FIN pos=~S vector=~S\n" pos (vector-length vect))
; (eprintf "A LA FIN pos=~S vector=~S\n" pos (vector-length vect))
vect)))
......@@ -343,14 +369,6 @@
;;;; DISASSEMBLE
;;;;
;;;; ======================================================================
(define (find-opcode opcode)
(let Loop ((l INSTRUCTION-SET))
(cond
((null? l) (panic "Cannot decode ~S opcode" opcode))
((= (cadar l) opcode) (car l))
(else (Loop (cdr l))))))
(define (disassemble-code v out)
(define (show x)
(format #f "~A~A~A"
......@@ -366,7 +384,7 @@
(let Loop ((pos 0))
(if (< pos len)
;; Disassemble an instruction
(let* ((instr (find-opcode (vector-ref v pos)))
(let* ((instr (find-instruction-infos (vector-ref v pos)))
(mnemonic (car instr))
(params (caddr instr)))
(format out "\n~A: ~A" (show pos) (pretty-mnemonic mnemonic))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 11-Feb-2007 21:51 (eg)
;;;; Last file update: 23-Feb-2007 15:47 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -275,7 +275,11 @@ doc>
((4) (em 'LOCAL-REF4 'LOCAL-SET4))
(else (em 'LOCAL-REF 'LOCAL-SET idx)))
;; local variable in a "between" block
(em 'DEEP-LOCAL-REF 'DEEP-LOCAL-SET (make-word lev idx))))
(let ((arg (make-word lev idx)))
(if (small-integer-constant? arg)
(em 'DEEP-LOCAL-REF 'DEEP-LOCAL-SET (make-word lev idx))
(em 'DEEP-LOC-REF-FAR 'DEEP-LOC-SET-FAR ;; Use a FAR variants
(fetch-constant (cons lev idx)))))))
(else (loop2 (+ idx 1) (cdr l))))))))
......
This diff is collapsed.
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: 22-Feb-2007 17:42 (eg)
* Last file update: 23-Feb-2007 15:40 (eg)
*/
......
......@@ -141,8 +141,21 @@
# define IN_SINT_SUB2 136
# define IN_SINT_MUL2 137
# define IN_SINT_DIV2 138
# define UNUSED_29 139
# define UNUSED_28 140
# define UNUSED_27 141
# define UNUSED_26 142
# define UNUSED_25 143
# define UNUSED_24 144
# define UNUSED_23 145
# define UNUSED_22 146
# define UNUSED_21 147
# define UNUSED_20 148
# define DEEP_LOC_REF_FAR 149
# define DEEP_LOC_SET_FAR 150
# define CREATE_CLOSURE_FAR 151
# define NB_VM_INSTR (IN_SINT_DIV2 +1)
# define NB_VM_INSTR (CREATE_CLOSURE_FAR +1)
#endif
......@@ -288,6 +301,19 @@ static void *jump_table[] = {
&&lab_IN_SINT_SUB2 ,
&&lab_IN_SINT_MUL2 ,
&&lab_IN_SINT_DIV2 ,
&&lab_UNUSED_29 ,
&&lab_UNUSED_28 ,
&&lab_UNUSED_27 ,
&&lab_UNUSED_26 ,
&&lab_UNUSED_25 ,
&&lab_UNUSED_24 ,
&&lab_UNUSED_23 ,
&&lab_UNUSED_22 ,
&&lab_UNUSED_21 ,
&&lab_UNUSED_20 ,
&&lab_DEEP_LOC_REF_FAR ,
&&lab_DEEP_LOC_SET_FAR ,
&&lab_CREATE_CLOSURE_FAR ,
NULL};
#endif
#undef DEFINE_JUMP_TABLE
......@@ -435,6 +461,19 @@ static char *name_table[] = {
"IN_SINT_SUB2 ",
"IN_SINT_MUL2 ",
"IN_SINT_DIV2 ",
"UNUSED_29 ",
"UNUSED_28 ",
"UNUSED_27 ",
"UNUSED_26 ",
"UNUSED_25 ",
"UNUSED_24 ",
"UNUSED_23 ",
"UNUSED_22 ",
"UNUSED_21 ",
"UNUSED_20 ",
"DEEP_LOC_REF_FAR ",
"DEEP_LOC_SET_FAR ",
"CREATE_CLOSURE_FAR ",
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: 22-Feb-2007 20:12 (eg)
* Last file update: 23-Feb-2007 16:23 (eg)
*/
// INLINER values
......@@ -992,6 +992,25 @@ CASE(DEEP_LOCAL_REF) {
vm->val = FRAME_LOCAL(e, SECOND_BYTE(info));
NEXT1;
}
CASE(DEEP_LOC_REF_FAR) {
/* DEEP-LOCAL-REF but FAR (arg is a cons). (This is inefficient but rare) */
SCM info = fetch_const();
int level;
SCM e = vm->env;
if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
STk_panic("DEEP_LOCAL_REF_FAR with ~S", info);
/* Go down in the dynamic environment */
for (level = INT_VAL(CAR(info)); level; level--)
e = (SCM) FRAME_NEXT(e);
vm->val = FRAME_LOCAL(e, INT_VAL(CDR(info)));
NEXT1;
}
CASE(DEEP_LOC_REF_PUSH) {
int level, info = fetch_next();
SCM e = vm->env;
......@@ -1049,6 +1068,25 @@ CASE(DEEP_LOCAL_SET) {
}
CASE(DEEP_LOC_SET_FAR) {
/* DEEP-LOCAL-SET but FAR (arg is a cons) (This is inefficient but rare) */
SCM info = fetch_const();
int level;
SCM e = vm->env;
if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
STk_panic("DEEP_LOCAL_SET_FAR with ~S", info);
/* Go down in the dynamic environment */
for (level = INT_VAL(CAR(info)); level; level--)
e = (SCM) FRAME_NEXT(e);
FRAME_LOCAL(e, INT_VAL(CDR(info))) = vm->val;
NEXT0;
}
CASE(GOTO) { offset = fetch_next(); vm->pc += offset; NEXT;}
CASE(JUMP_FALSE) {
offset = fetch_next();
......@@ -1128,7 +1166,18 @@ CASE(CREATE_CLOSURE) {
vm->pc += vm->pc[0] + 1;
NEXT1;
}
CASE(CREATE_CLOSURE_FAR) {
/* CREATE_CLOSURE but with a cons instead of 2 integers */
SCM info = fetch_const();
if (!CONSP(info) || !INTP(CAR(info)) || !INTP(CDR(info)))
STk_panic("CREATE_CLOSURE_FAR with ~S", info);
vm->env = clone_env(vm->env, vm);
vm->val = STk_make_closure(vm->pc+1, INT_VAL(CAR(info)), INT_VAL(CDR(info)),
vm->constants, vm->env);
vm->pc += INT_VAL(CAR(info));
NEXT1;
}
CASE(PREPARE_CALL) { PREP_CALL(); NEXT; }
CASE(RETURN) { RET_CALL(); NEXT; }
......@@ -1285,6 +1334,17 @@ CASE(UNUSED_16)
CASE(UNUSED_17)
CASE(UNUSED_18)
CASE(UNUSED_19)
CASE(UNUSED_20)
CASE(UNUSED_21)
CASE(UNUSED_22)
CASE(UNUSED_23)
CASE(UNUSED_24)
CASE(UNUSED_25)
CASE(UNUSED_26)
CASE(UNUSED_27)
CASE(UNUSED_28)
CASE(UNUSED_29)
{
;
}
......
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