picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

commit 44ad7d70588a97df7ed0021c79111cdc96b25d94
parent 9dea8e9165a9e178779b4f9106e10905c68fb213
Author: Alexander Burger <abu@software-lab.de>
Date:   Mon, 22 Oct 2012 20:47:26 +0200

emu64 continued
Diffstat:
Msrc64/arch/emu.l | 214++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------
1 file changed, 146 insertions(+), 68 deletions(-)

diff --git a/src64/arch/emu.l b/src64/arch/emu.l @@ -1,4 +1,4 @@ -# 19oct12abu +# 22oct12abu # (c) Software Lab. Alexander Burger # Byte order @@ -23,8 +23,9 @@ (F . T) ) # Emulator specific -(off *AsmOpcodes *AsmData *AsmCode *Labels *SysFun *BaseData *BaseCode) -(zero *AsmPos) +(off *AsmData *AsmCode *AsmOpcodes *Labels *SysFun) +(off *BaseData *BaseCode *BaseOpcodes) +(zero *AsmPos *OpOffs) # Direct address expressions (de directExpr (Str) @@ -43,8 +44,8 @@ (setq X (- (car X) (car Y))) ) (set X (Op (car X) Y)) (setq X (cons (Op X (car Y)))) - (and (sym? X) (absCode X) (setq X @)) - (and (sym? Y) (absCode Y) (setq Y @)) + (and (sym? X) (or (baseCode X) (absCode X)) (setq X @)) + (and (sym? Y) (or (baseCode Y) (absCode Y)) (setq Y @)) (setq X (Op X Y)) ) ) ) X ) ) @@ -58,17 +59,14 @@ (let X (pop 'Lst) (cond ((num? X) X) - ((get *AsmData X) - (cons (car @) (if *FPic "Local+@1" "Data+@1")) ) ((and *FPic (get *BaseData X)) (cons @ "Data+@1") ) - ((absCode X) - (cons @ - (if *FPic - (pack "(" *Label "+@1)") - "(Code+@1)" ) ) ) - ((and *FPic (get *BaseCode X)) + ((get *AsmData X) + (cons (car @) (if *FPic "LibData+@1" "Data+@1")) ) + ((baseCode X) (cons @ "(Code+@1)") ) + ((absCode X) + (cons @ (if *FPic "(LibCode+@1)" "(Code+@1)")) ) ((= "+" X) (_term)) ((= "-" X) (- (_term))) ((= "(" X) (prog1 (_aggr) (pop 'Lst))) @@ -209,17 +207,18 @@ (de opcode ("X" "Args" "Body") (cond ((= "X" '(nop)) 0) - ((assoc "X" *AsmOpcodes) (index @ *AsmOpcodes)) + ((index "X" *BaseOpcodes) @) + ((assoc "X" *AsmOpcodes) (+ *OpOffs (index @ *AsmOpcodes))) (T (queue '*AsmOpcodes (cons "X" - ~(as *Dbg + ~(as (and *Dbg (not *FPic)) (pack "fprintf(stderr, \"%d: %s\\n\", PC-Code-1, \"" (fmtInstruction "X") "\");" ) ) (mapcar '((S) (apply text "Args" S)) "Body") ) ) - (length *AsmOpcodes) ) ) ) + (+ *OpOffs (length *AsmOpcodes)) ) ) ) (de addCode (C) (if (and *AsmCode (not (caar @))) @@ -230,6 +229,9 @@ (de genCode Args (addCode (cons (env (pop 'Args)) Args)) ) +(de baseCode (Adr) + (and *FPic (get *BaseCode Adr)) ) + (de absCode (Lbl) (val (car (idx '*Labels Lbl))) ) @@ -544,9 +546,19 @@ (asm call (Adr A) (nond (A # Absolute - (genCode (Adr) (list 'call Adr) ((absCode Adr)) - "S.p -= 8, *(uint16_t**)S.p = PC;" - "PC = Code + @1;" ) ) + (cond + ((baseCode Adr) + (genCode (Adr) (list 'call Adr) ((baseCode Adr)) + "S.p -= 8, *(uint16_t**)S.p = PC;" + "PC = Code + @1;" ) ) + (*FPic + (genCode (Adr) (list 'call Adr) ((absCode Adr)) + "S.p -= 8, *(uint16_t**)S.p = PC;" + "PC = LibCode + @1;" ) ) + (T + (genCode (Adr) (list 'call Adr) ((absCode Adr)) + "S.p -= 8, *(uint16_t**)S.p = PC;" + "PC = Code + @1;" ) ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr A) (list 'call (list Adr)) (Adr) "S.p -= 8, *(uint16_t**)S.p = PC;" @@ -559,11 +571,19 @@ (asm jmp (Adr A) (nond (A # Absolute - (if (localAddr Adr) - (genCode (Adr) (list 'jmp (relCode Adr)) ((relCode Adr)) - "PC += @1;" ) - (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) - "PC = Code + @1;" ) ) ) + (cond + ((localAddr Adr) + (genCode (Adr) (list 'jmp (relCode Adr)) ((relCode Adr)) + "PC += @1;" ) ) + ((baseCode Adr) + (genCode (Adr) (list 'jmp Adr) ((baseCode Adr)) + "PC = Code + @1;" ) ) + (*FPic + (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) + "PC = LibCode + @1;" ) ) + (T + (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) + "PC = Code + @1;" ) ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr A) (list 'jmp (list Adr)) (Adr) "PC = (uint16_t*)@1.p;" ) ) @@ -574,13 +594,23 @@ (de _jmp (Opc Test) (nond (A # Absolute - (if (localAddr Adr) - (genCode (Adr Opc Test) (list Opc (relCode Adr)) ((relCode Adr) Test) - "if (@2)" - " PC += @1;" ) - (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) - "if (@2)" - " PC = Code + @1;") ) ) + (cond + ((localAddr Adr) + (genCode (Adr Opc Test) (list Opc (relCode Adr)) ((relCode Adr) Test) + "if (@2)" + " PC += @1;" ) ) + ((baseCode Adr) + (genCode (Adr Opc Test) (list Opc Adr) ((baseCode Adr) Test) + "if (@2)" + " PC = Code + @1;") ) + (*FPic + (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) + "if (@2)" + " PC = LibCode + @1;") ) + (T + (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) + "if (@2)" + " PC = Code + @1;") ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr Opc Test) (list Opc Adr) (Adr Test) "if (@2)" @@ -949,8 +979,11 @@ (de prolog (File) (if *FPic (in "emu.symtab" - (setq *BaseData (read)) - (setq *BaseCode (read)) ) + (setq + *BaseData (read) + *BaseCode (read) + *BaseOpcodes (make (while (read) (chain @))) + *OpOffs (length *BaseOpcodes) ) ) (genCode NIL '(<eval+>) NIL # Code + 0 "PC = *(uint16_t**)S.p, S.p += 8;" "L.p = ((ptr)S.p)->p, S.p += 8;" ) @@ -1012,6 +1045,9 @@ (mapc prinl (if *FPic (quote + "extern uint16_t Code[];" + "uint16_t LibCode[];" + NIL "extern uint16_t *PC;" "extern uint8_t *Stack;" "extern op A, C, E, X, Y, Z, L, S;" @@ -1022,10 +1058,13 @@ "extern void begin(int,int,int,int,int,int,int);" "extern void *argv(int,ptr);" "extern void retv(int,ptr);" - "extern uint16_t Code[];" NIL - "op Local[] = {" ) + "extern op Data[];" + NIL + "op LibData[] = {" ) (quote + "uint16_t Code[];" + NIL "uint16_t *PC;" "uint8_t *Stack;" "op A, C, E, X, Y, Z, L, S;" @@ -1126,8 +1165,6 @@ " p[i].n = (uint64_t)(unsigned long)((uint8_t**)p)[i];" "}" NIL - "uint16_t Code[];" - NIL "op Data[] = {" ) ) ) ) (de prOpcode (I X) @@ -1138,7 +1175,10 @@ ": " (if (=0 X) "nop" - (fmtInstruction (get *AsmOpcodes X 1)) ) ) ) + (fmtInstruction + (or + (get *BaseOpcodes X) + (get *AsmOpcodes (- X *OpOffs) 1) ) ) ) ) ) (de epilog (File) (setq @@ -1174,11 +1214,28 @@ (for ((J . L) (cddr D) (> I J) (cdr L)) (NIL (> I J)) # Temporary (03oct12abu) (inc 'N (if (num? (car L)) 1 8)) ) - (prin " {.p = (uint8_t*)Data+" N "},") ) ) + (prin + " {.p = (uint8_t*)" + (and *FPic "Lib") + "Data+" + N + "}," ) ) ) ((asoq X *AsmData) - (prin " {.p = (uint8_t*)Data+" (cadr @) "},") ) + (let N @ + (prin + " {.p = (uint8_t*)" + (and *FPic "Lib") + "Data+" + (cadr N) + "}," ) ) ) ((absCode X) - (prin " {.p = (uint8_t*)(Code+" @ ")},") ) + (let N @ + (prin + " {.p = (uint8_t*)(" + (and *FPic "Lib") + "Code+" + N + ")}," ) ) ) (T (quit "No value" X)) ) ) (Bytes (prin (and (> I 1) ", ") X) @@ -1198,7 +1255,7 @@ (when *SysFun (mapc prinl (flip @)) (prinl) ) - (prinl "uint16_t Code[] = {") + (prinl "uint16_t " (and *FPic "Lib") "Code[] = {") (for (I . X) *AsmCode (for C (cdr X) (unless (pre? "." C) # Omit local labels @@ -1206,21 +1263,38 @@ (prOpcode I (car X)) ) (prinl "};") (prinl) - (mapc prinl - (quote - "static void run(int i) {" - " op tmp;" - NIL - " PC = Code + i;" - " for (;;) {" - " switch (*PC++) {" - " case 0: // nop" - " break;" ) ) + (if *FPic + (mapc prinl + (quote + "static void opc() {" + " op tmp;" + NIL + " switch (PC[-1]) {" ) ) + (mapc prinl + (quote + "static void run(int i) {" + " op tmp;" + NIL + " PC = Code + i;" + " for (;;) {" + " switch (*PC++) {" + " case 0: // nop" + " break;" ) ) ) (for (C . L) *AsmOpcodes - (prinl " case " C ": // " (fmtInstruction (car L))) + (prinl + (unless *FPic " ") + " case " + (+ *OpOffs C) + ": // " + (fmtInstruction (car L)) ) (for S (cdr L) - (prinl " " S) ) - (prinl " break;") ) + (prinl + (unless *FPic " ") + " " + S ) ) + (prinl + (unless *FPic " ") + " break;" ) ) (mapc prinl (quote " default:" @@ -1231,9 +1305,9 @@ " fprintf(stderr, \" %llX %llX %llX %llX %llX %llX %d%d%d %llX %llX\\n\"," " A.n, C.n, E.n, X.n, Y.n, Z.n," " !Result, (int64_t)Result<0, Carry," - " L.n, S.n );" ) - " }" - "}" ) ) + " L.n, S.n );" ) ) ) + (unless *FPic (prinl " }")) + (prinl "}") (unless *FPic (mapc prinl (quote @@ -1252,15 +1326,19 @@ (prinl (pack " run(" (absCode "main") ");")) (prinl " return 0;") (prinl "}") - (out "emu.symtab" - (println - (mapcar '((D) (cons (car D) (cadr D))) - *AsmData ) ) - (println - (make - (for (I . X) *AsmCode - (for Lbl (cdr X) - (unless (pre? "." Lbl) - (link (cons Lbl (dec I))) ) ) ) ) ) ) ) ) + (if *FPic + (out "+emu.symtab" + (println (mapcar car *AsmOpcodes)) ) + (out "emu.symtab" + (println + (mapcar '((D) (cons (car D) (cadr D))) + *AsmData ) ) + (println + (make + (for (I . X) *AsmCode + (for Lbl (cdr X) + (unless (pre? "." Lbl) + (link (cons Lbl (dec I))) ) ) ) ) ) + (println (mapcar car *AsmOpcodes)) ) ) ) ) # vi:et:ts=3:sw=3