Commit 2ad4d4c3 authored by mb0's avatar mb0

Up.

parent 64223137
......@@ -2,7 +2,7 @@
The SPEC grammar and all code not otherwise declared is hereby submitted to
the Public Domain. All warranties are disclaimed.
The codebase includes code from several resources:
The codebase includes code fragments from several resources:
## MLTON
......
......@@ -250,8 +250,22 @@ structure C = struct
PrettyC.call' ("__RECORD_END", args)])]
end
| UNT => PrettyC.local1(x, str "__UNIT")
| STR s => (* TODO *) PrettyC.local1(x, str "__UNIT")
| _ => (* TODO *) raise Fail "unimplemented letval binding"
| STR s =>
let
val args = seq [lp, PrettyC.var x, rp]
in
PrettyC.cseq
[PrettyC.local0 x,
indent 2
(PrettyC.cseq
[PrettyC.call' ("__ROPE_BEGIN", args),
PrettyC.call'
("__ROPE_FROMCSTRING",
seq [lp,str"\"",str s,str"\"",rp]),
PrettyC.call' ("__ROPE_END", args)])]
end
| _ => (* TODO *) raise Fail "Unimplemented literal"
fun emitFlow f =
case f of
......
......@@ -85,11 +85,11 @@ __obj __zx (__obj x) {
return (y);
}
__obj __concat (__obj a_, __obj b_) {
__word a = a_->bv.vec;
__word b = b_->bv.vec;
__word szOfA = a_->bv.sz;
__word szOfB = b_->bv.sz;
__obj __concat (__obj A, __obj B) {
__word a = A->bv.vec;
__word b = B->bv.vec;
__word szOfA = A->bv.sz;
__word szOfB = B->bv.sz;
__word sz = szOfA + szOfB;
__LOCAL0(x);
__BV_BEGIN(x,sz);
......@@ -98,18 +98,50 @@ __obj __concat (__obj a_, __obj b_) {
return (x);
}
__obj __equal (__obj a_, __obj b_) {
__word a = a_->bv.vec;
__word b = b_->bv.vec;
__word szOfA = a_->bv.sz;
__word szOfB = b_->bv.sz;
__obj __concatstring (__obj A, __obj B) {
__LOCAL0(R);
__ROPE_BEGIN(R);
__ROPE_CONCAT(A,B);
__ROPE_END(R);
return (R);
}
__obj __flattenstring(__obj o, char* buf, __word sz) {
switch (__TAG(o)) {
case __ROPELEAF: {
__word l = strlen(buf);
sz = sz - l;
if (sz == 0) return (__UNIT);
__word szz = o->ropeleaf.sz;
__word len = szz >= sz ? sz-1 : szz;
memcpy(buf+l,o->ropeleaf.blob,len);
buf[l+len] = '\0';
return (__UNIT);
break;
}
case __ROPEBRANCH: {
__flattenstring(o->ropebranch.left,buf,sz);
__flattenstring(o->ropebranch.right,buf,sz);
return (__UNIT);
break;
}
default:
__fatal("Object not of type {ROPE}");
};
}
__obj __equal (__obj A, __obj B) {
__word a = A->bv.vec;
__word b = B->bv.vec;
__word szOfA = A->bv.sz;
__word szOfB = B->bv.sz;
__LOCAL(x, (a == b && szOfA == szOfB) ? __TRUE : __FALSE);
return (x);
}
__obj __not (__obj a_) {
__word a = a_->bv.vec;
__word sz = a_->bv.sz;
__obj __not (__obj A) {
__word a = A->bv.vec;
__word sz = A->bv.sz;
__LOCAL0(x);
__BV_BEGIN(x,sz);
__BV_INIT(~a & ((1 << sz)-1));
......@@ -313,6 +345,17 @@ __obj __evalPure (__obj (*f)(__obj,__obj), __obj x) {
return (__runWithState(f,x));
}
__obj __pretty (__obj (*f)(__obj,__obj), __obj insn, char* buf, __word sz) {
__obj str = __evalPure(f,insn);
if (___isNil(str) || sz == 0) {
return (str);
} else {
buf[0] = '\0';
__flattenstring(str,buf,sz);
return (str);
}
}
/* Caller needs to reset the heap with `__resetHeap()` */
__word __decode (__obj (*f)(__obj,__obj), __char* blob, __word sz, __obj* insn) {
__obj o = __eval(f,blob,sz);
......@@ -374,6 +417,26 @@ const __char* __tagName (__word i) {
return (unknown);
}
__obj __showbitvec (__obj o) {
char fmt[16];
snprintf(fmt,16,"0x%zx",o->bv.vec);
__LOCAL0(R);
__ROPE_BEGIN(R);
__ROPE_FROMCSTRING(fmt);
__ROPE_END(R);
return (R);
}
__obj __showint (__obj o) {
char fmt[64];
snprintf(fmt,64,"0x%ld",o->z.value);
__LOCAL0(R);
__ROPE_BEGIN(R);
__ROPE_FROMCSTRING(fmt);
__ROPE_END(R);
return (R);
}
__obj __print (__obj o) {
switch (__TAG(o)) {
case __CLOSURE:
......@@ -411,6 +474,23 @@ __obj __print (__obj o) {
printf("}");
break;
}
case __ROPELEAF: {
char buf[7+1];
__word sz = o->ropeleaf.sz;
__word len = sz > 7 ? 7 : sz;
memcpy(buf,o->ropeleaf.blob,len);
buf[len] = '\0';
printf("{tag=__ROPELEAF,sz=%lu,blob=%s..}",sz,buf);
break;
}
case __ROPEBRANCH: {
printf("{tag=__ROPEBRANCH,left=");
__print(o->ropebranch.left);
printf(",right=");
__print(o->ropebranch.right);
printf("}");
break;
}
case __LABEL:
printf("{tag=__LABEL,f=%p}",o->label.f);
break;
......
......@@ -86,6 +86,9 @@
/** ## Records */
/* PERF: A more efficient data-structure for records is needed.
* maybe versioned arrays or some kind of list/stack with the
* most recently added fields on-top. */
#define __RECORD_BEGIN(Cname, n)\
__CHECK_HEAP(n+1)
......@@ -118,7 +121,31 @@
#define __RECORD_SELECT(Cname, field)\
__recordLookup(((struct __record*)Cname), field)->tagged.payload
/** ## Ropes/Strings */
#define __ROPE_BEGIN(Cname) /* TODO: CHECK HEAP */
#define __ROPE_CONCAT(a,b)\
{__objref o = __ALLOC1();\
o->ropebranch.header.tag = __ROPEBRANCH;\
o->ropebranch.left = a;\
o->ropebranch.right = b;
#define __ROPE_FROMCSTRING(s)\
{__objref o = __ALLOC1();\
__int len = strlen(s);\
__int n = len/sizeof(__unwrapped_obj);\
n = ((len % sizeof(__unwrapped_obj)) == 0) ? n : n + 1;\
o->ropeleaf.header.tag = __ROPELEAF;\
o->ropeleaf.sz = len;\
__objref p = __ALLOCN(n);\
memcpy(p,s,len);\
o->ropeleaf.blob = (__char*)p;
#define __ROPE_END(Cname)\
Cname = __WRAP(o);}
/** ## Bitvectors */
#define __BV_BEGIN(Cname, n)\
......@@ -186,6 +213,8 @@ enum __tag {
__RECORD,
__NIL,
__BLOB,
__ROPELEAF,
__ROPEBRANCH,
__LABEL
};
......@@ -227,6 +256,16 @@ union __unwrapped_obj {
__char* blob;
__word sz;
} blob;
struct __unwrapped_ropeleaf {
__header header;
__char* blob;
__word sz;
} ropeleaf;
struct __unwrapped_ropebranch {
__header header;
__obj left;
__obj right;
} ropebranch;
struct __unwrapped_int {
__header header;
__int value;
......@@ -257,6 +296,14 @@ union __wrapped_obj {
__char* blob;
__word sz;
} blob;
struct __ropeleaf {
__char* blob;
__word sz;
} ropeleaf;
struct __ropebranch {
__obj left;
__obj right;
} ropebranch;
struct __int {
__int value;
} z;
......@@ -392,14 +439,19 @@ __obj __raise(__obj);
__obj __not(__obj);
__obj __isNil(__obj);
__obj __printState();
__obj __concatstring(__obj,__obj);
__obj __showbitvec(__obj);
__obj __showint(__obj);
__obj __flattenstring(__obj,char*,__word);
/* ## API helpers */
int ___isNil(__obj);
__obj __runWithState(__obj(*)(__obj,__obj),__obj);
__obj __evalPure(__obj(*)(__obj,__obj),__obj);
__obj __eval(__obj(*)(__obj,__obj),__char*, __word);
__obj __eval(__obj(*)(__obj,__obj),__char*,__word);
__word __decode(__obj(*)(__obj,__obj),__char*,__word,__obj*);
__obj __pretty(__obj(*)(__obj,__obj),__obj,char*,__word);
__obj __translate(__obj(*)(__obj,__obj),__obj);
#endif /* __RUNTIME_H */
......
......@@ -253,7 +253,9 @@ structure Number =
fun equals (T r, T r') = Real.== (r, r')
fun fromReal r = if r < 0.0 then raise Fail "Number.fromReal" else T r
(* fun fromReal r = if r < 0.0 then raise Fail "Number.fromReal" else T r *)
fun fromReal r = T r
val toReal = fn T r => r
......
# vim:ts=3:sw=3:expandtab
export = pretty
val pretty i = show/instruction i
val show/unop x = show/operand x.operand
val show/binop x = show/operand x.first +++ ", " +++ show/operand x.second
val -++ a b = a +++ " " +++ b
val show/side-effect eff =
case eff of
NONE: ""
| INCR: "+"
| DECR: "-"
end
val show/operand opnd =
case opnd of
REG r: show/register r
| REGHL r: show/register r.regh +++ "/" +++ show/register r.regl
| IOREG ior: show/io-register ior
| IMM imm: show/operand/imm imm
| OPSE op: show/operand op.op +++ show/side-effect op.se
| OPDI op: show/operand op.op +++ "+" +++ show/operand/imm op.imm
end
val show/operand/imm imm =
case imm of
IMM3 x: showbitvec x
| IMM4 x: showbitvec x
| IMM6 x: showbitvec x
| IMM7 x: showbitvec x
| IMM8 x: showbitvec x
| IMM12 x: showbitvec x
| IMM16 x: showbitvec x
| IMM22 x: showbitvec x
end
val show/instruction i =
case i of
ADC x: "ADC" -++ show/binop x
| ADD x: "ADD" -++ show/binop x
| ADIW x: "ADIW" -++ show/binop x
| AND x: "AND" -++ show/binop x
| ANDI x: "ANDI" -++ show/binop x
| ASR x: "ASR" -++ show/unop x
| BCLR x: "BCLR" -++ show/unop x
| BLD x: "BLD" -++ show/binop x
| BRBC x: "BRBC" -++ show/binop x
| BRBS x: "BRBS" -++ show/binop x
| BRCC x: "BRCC" -++ show/unop x
| BRCS x: "BRCS" -++ show/unop x
| BREAK: "BREAK"
| BREQ x: "BREQ" -++ show/unop x
| BRGE x: "BRGE" -++ show/unop x
| BRHC x: "BRHC" -++ show/unop x
| BRHS x: "BRHS" -++ show/unop x
| BRID x: "BRID" -++ show/unop x
| BRIE x: "BRIE" -++ show/unop x
| BRLO x: "BRLO" -++ show/unop x
| BRLT x: "BRLT" -++ show/unop x
| BRMI x: "BRMI" -++ show/unop x
| BRNE x: "BRNE" -++ show/unop x
| BRPL x: "BRPL" -++ show/unop x
| BRSH x: "BRSH" -++ show/unop x
| BRTC x: "BRTC" -++ show/unop x
| BRTS x: "BRTS" -++ show/unop x
| BRVC x: "BRVC" -++ show/unop x
| BRVS x: "BRVS" -++ show/unop x
| BSET x: "BSET" -++ show/unop x
| BST x: "BST" -++ show/binop x
| CALL x: "CALL" -++ show/unop x
| CBI x: "CBI" -++ show/binop x
| CBR x: "CBR" -++ show/binop x
| CLC: "CLC"
| CLH: "CLH"
| CLI: "CLI"
| CLN: "CLN"
| CLR x: "CLR" -++ show/unop x
| CLS: "CLS"
| CLT: "CLT"
| CLV: "CLV"
| CLZ: "CLZ"
| COM x: "COM" -++ show/unop x
| CP x: "CP" -++ show/binop x
| CPC x: "CPC" -++ show/binop x
| CPI x: "CPI" -++ show/binop x
| CPSE x: "CPSE" -++ show/binop x
| DEC x: "DEC" -++ show/unop x
| DES x: "DES" -++ show/unop x
| EICALL: "EICALL"
| EIJMP: "EIJMP"
| ELPM x: "ELPM" -++ show/binop x
| EOR x: "EOR" -++ show/binop x
| FMUL x: "FMUL" -++ show/binop x
| FMULS x: "FMULS" -++ show/binop x
| FMULSU x: "FMULSU" -++ show/binop x
| ICALL: "ICALL"
| IJMP: "IJMP"
| IN x: "IN" -++ show/binop x
| INC x: "INC" -++ show/unop x
| JMP x: "JMP" -++ show/unop x
| LAC x: "LAC" -++ show/binop x
| LAS x: "LAS" -++ show/binop x
| LAT x: "LAT" -++ show/binop x
| LD x: "LD" -++ show/binop x
| LDI x: "LDI" -++ show/binop x
| LDS x: "LDS" -++ show/binop x
| LPM x: "LPM" -++ show/binop x
| LSL x: "LSL" -++ show/unop x
| LSR x: "LSR" -++ show/unop x
| MOV x: "MOV" -++ show/binop x
| MOVW x: "MOVW" -++ show/binop x
| MUL x: "MUL" -++ show/binop x
| MULS x: "MULS" -++ show/binop x
| MULSU x: "MULSU" -++ show/binop x
| NEG x: "NEG" -++ show/unop x
| NOP: "NOP"
| OR x: "OR" -++ show/binop x
| ORI x: "ORI" -++ show/binop x
| OUT x: "OUT" -++ show/binop x
| POP x: "POP" -++ show/unop x
| PUSH x: "PUSH" -++ show/unop x
| RCALL x: "RCALL" -++ show/unop x
| RET: "RET"
| RETI: "RETI"
| RJMP x: "RJMP" -++ show/unop x
| ROL x: "ROL" -++ show/unop x
| ROR x: "ROR" -++ show/unop x
| SBC x: "SBC" -++ show/binop x
| SBCI x: "SBCI" -++ show/binop x
| SBI x: "SBI" -++ show/binop x
| SBIC x: "SBIC" -++ show/binop x
| SBIS x: "SBIS" -++ show/binop x
| SBIW x: "SBIW" -++ show/binop x
| SBR x: "SBR" -++ show/binop x
| SBRC x: "SBRC" -++ show/binop x
| SBRS x: "SBRS" -++ show/binop x
| SEC: "SEC"
| SEH: "SEH"
| SEI: "SEI"
| SEN: "SEN"
| SER x: "SER" -++ show/unop x
| SES: "SES"
| SET: "SET"
| SEV: "SEV"
| SEZ: "SEZ"
| SLEEP: "SLEEP"
| SPM x: "SPM" -++ show/unop x
| ST x: "ST" -++ show/binop x
| STS x: "STS" -++ show/binop x
| SUB x: "SUB" -++ show/binop x
| SUBI x: "SUBI" -++ show/binop x
| SWAP x: "SWAP" -++ show/unop x
| TST x: "TST" -++ show/unop x
| WDR: "WDR"
| XCH x: "XCH" -++ show/binop x
end
val show/register r =
case r of
R0 : "R0"
| R1 : "R1"
| R2 : "R2"
| R3 : "R3"
| R4 : "R4"
| R5 : "R5"
| R6 : "R6"
| R7 : "R7"
| R8 : "R8"
| R9 : "R9"
| R10: "R10"
| R11: "R11"
| R12: "R12"
| R13: "R13"
| R14: "R14"
| R15: "R15"
| R16: "R16"
| R17: "R17"
| R18: "R18"
| R19: "R19"
| R20: "R20"
| R21: "R21"
| R22: "R22"
| R23: "R23"
| R24: "R24"
| R25: "R25"
| R26: "R26"
| R27: "R27"
| R28: "R28"
| R29: "R29"
| R30: "R30"
| R31: "R31"
end
val show/io-register r =
case r of
IO0 : "IO0"
| IO1 : "IO1"
| IO2 : "IO2"
| IO3 : "IO3"
| IO4 : "IO4"
| IO5 : "IO5"
| IO6 : "IO6"
| IO7 : "IO7"
| IO8 : "IO8"
| IO9 : "IO9"
| IO10: "IO10"
| IO11: "IO11"
| IO12: "IO12"
| IO13: "IO13"
| IO14: "IO14"
| IO15: "IO15"
| IO16: "IO16"
| IO17: "IO17"
| IO18: "IO18"
| IO19: "IO19"
| IO20: "IO20"
| IO21: "IO21"
| IO22: "IO22"
| IO23: "IO23"
| IO24: "IO24"
| IO25: "IO25"
| IO26: "IO26"
| IO27: "IO27"
| IO28: "IO28"
| IO29: "IO29"
| IO30: "IO30"
| IO31: "IO31"
| IO32: "IO32"
| IO33: "IO33"
| IO34: "IO34"
| IO35: "IO35"
| IO36: "IO36"
| IO37: "IO37"
| IO38: "IO38"
| IO39: "IO39"
| IO40: "IO40"
| IO41: "IO41"
| IO42: "IO42"
| IO43: "IO43"
| IO44: "IO44"
| IO45: "IO45"
| IO46: "IO46"
| IO47: "IO47"
| IO48: "IO48"
| IO49: "IO49"
| IO50: "IO50"
| IO51: "IO51"
| IO52: "IO52"
| IO53: "IO53"
| IO54: "IO54"
| IO55: "IO55"
| IO56: "IO56"
| IO57: "IO57"
| IO58: "IO58"
| IO59: "IO59"
| IO60: "IO60"
| IO61: "IO61"
| IO62: "IO62"
| IO63: "IO63"
end
all: cmusl-cli
cmusl-cli:
/usr/musl/bin/musl-gcc -pipe -O3 -Wall -static -I. -I../../.. -Wfatal-errors cli.c ../../../dis.c -DRELAXEDFATAL -o musl-cli
/* vim:cindent:ts=2:sw=2:expandtab */
#include <dis.h>
int main (int argc, char** argv) {
__char blob[15];
char fmt[1024];
__word sz = 15;
__obj insn;
int i,c;
for (i=0;i<sz;i++) {
int x = fscanf(stdin,"%x",&c);
switch (x) {
case EOF:
goto done;
case 0:
__fatal("invalid input; should be in hex form: '0f 0b ..'");
}
blob[i] = c & 0xff;
}
done:
__decode(__decode__,blob,i,&insn);
if (___isNil(insn))
__fatal("decode failed");
else {
__pretty(__pretty__,insn,fmt,1024);
puts(fmt);
}
return (1);
}
# vim:filetype=sml:ts=3:sw=3:expandtab
# The following functions need to be defined elsewhere:
# - show/arch
export = prettyrreil
val prettyrreil ss = showrreil/stmts ss
val showrreil/stmts ss =
case ss of
SEM_NIL: ""
| SEM_CONS x: showrreil/stmt x.hd +++ "\n" +++ showrreil/stmts x.tl
end
val showrreil/stmt s =
case s of
SEM_ASSIGN x: showrreil/var x.lhs +++ " = " +++ showrreil/op x.rhs
| SEM_LOAD x: showrreil/var x.lhs +++ " = " showrreil/ptrderef x.size x.address
| SEM_STORE x: "*" +++ showrreil/address x.address +++ " = " +++ showrreil/op x.rhs
| SEM_LABEL x: showrreil/label x.id
| SEM_IF_GOTO_LABEL x: "if (" +++ showrreil/linear x.cond +++ ") goto label " +++ showrreil/label x.label
| SEM_IF_GOTO x: "if (" +++ showrreil/linear x.cond +++ ") goto " +++ showrreil/address x.target
| SEM_CALL x: "if (" +++ showrreil/linear x.cond +++ ") call " +++ showrreil/address x.target
| SEM_RETURN x: "if (" +++ showrreil/linear x.cond +++ ") return " +++ showrreil/address x.target
end
val showrreil/label l = "l" +++ showint l +++ ":"
val showrreil/op op =
case op of
SEM_LIN x: showrreil/arity1 x
| SEM_BSWAP x: "bswap" +++ showrreil/arity1 x
| SEM_MUL x: "mul" +++ showrreil/arity2 x
| SEM_DIV x: "div" +++ showrreil/arity2 x
| SEM_DIVS x: "divs" +++ showrreil/arity2 x
| SEM_MOD x: "mod" +++ showrreil/arity2 x
| SEM_SHL x: "shl" +++ showrreil/arity2 x
| SEM_SHR x: "shr" +++ showrreil/arity2 x
| SEM_SHRS x: "shrs" +++ showrreil/arity2 x
| SEM_AND x: "and" +++ showrreil/arity2 x
| SEM_OR x: "or" +++ showrreil/arity2 x
| SEM_XOR x: "xor" +++ showrreil/arity2 x
| SEM_SX x: "sx[" +++ showint x.fromsize +++ "." +++ showint x.size +++ "](" +++ showrreil/linear x.opnd1 +++ ")"
| SEM_ZX x: "zx[" +++ showint x.fromsize +++ "." +++ showint x.size +++ "](" +++ showrreil/linear x.opnd1 +++ ")"
| SEM_CMPEQ x: "==" +++ showrreil/cmp x
| SEM_CMPNEQ x: "/=" +++ showrreil/cmp x
| SEM_CMPLES x: "<=s" +++ showrreil/cmp x
| SEM_CMPLEU x: "<=u" +++ showrreil/cmp x
| SEM_CMPLTS x: "<s" +++ showrreil/cmp x
| SEM_CMPLTU x: "<u" +++ showrreil/cmp x
| SEM_ARB x: "arbitrary[" +++ showint x +++ "]"
end
val showrreil/arity1 x = "[" +++ showint x.size +++ "](" +++ showrreil/linear x.opnd1 +++ ")"
val showrreil/arity2 x = "[" +++ showint x.size +++ "](" +++ showrreil/linear x.opnd1 +++ "," +++ showrreil/linear x.opnd2 +++ ")"
val showrreil/cmp x = "[" +++ showint x.size +++ ".1](" +++ showrreil/linear x.opnd1 +++ "," +++ showrreil/linear x.opnd2 +++ ")"
val showrreil/ptrderef sz addr = "*[" +++ showint addr.size +++ "." +++ showint sz +++ "](" +++ showrreil/linear addr.address +++ ")"
val showrreil/address addr = "[" +++ showint addr.size +++ "](" +++ showrreil/linear addr.address +++ ")"
val showrreil/var x =
case x.offset of
0: showrreil/id x.id
| o: showrreil/id x.id +++ "/" +++ showint o
end
val showrreil/linear lin =
case lin of
SEM_LIN_VAR x: showrreil/var x
| SEM_LIN_IMM x: showint x.imm
| SEM_LIN_ADD x: showrreil/linear x.opnd1 +++ "+" +++ showrreil/linear x.opnd2
| SEM_LIN_SUB x: showrreil/linear x.opnd1 +++ "-" +++ showrreil/linear x.opnd2
| SEM_LIN_SCALE x:
case x.imm of
0: ""
| 1: showrreil/linear x.opnd
| s: showint s +++ "*" +++ showrreil/linear lin
end
end
val showrreil/id id =
case id of
ARCH_R x: show/arch x
| VIRT_EQ: "EQ"
| VIRT_NEQ: "NEQ"
| VIRT_LES: "LES"
| VIRT_LEU: "LEU"
| VIRT_LTS: "LTS"
| VIRT_LTU: "LTU"
| VIRT_T x: "T" +++ showint x
end
# vim:filetype=sml:ts=3:sw=3:expandtab
export = translate
type sem_id =
ARCH_RAX
| ARCH_RBX
| ARCH_RCX
| ARCH_RBP
| ARCH_ZF
| ARCH_CF
| ARCH_SF
| ARCH_OF
| ARCH_PF
| ARCH_AF
ARCH_R of int
| VIRT_EQ # ==
| VIRT_NEQ # /=