Commit 7558214c authored by Julian Kranz's avatar Julian Kranz

Merge branch 'master' of bitbucket.org:simona/gdsl-toolkit into experimental

parents 0214cd92 1ecb8f1f
......@@ -894,6 +894,7 @@ structure C1 = struct
| emitPrim s (GET_CON_IDXprim, [e],[t]) = seq [str "((", emitConType s t, str "*) ", emitExp s e , str ")->tag"]
| emitPrim s (GET_CON_ARGprim, [_,e],[FUNvtype (_,_,[t]),_]) = seq [str "((", emitConType s t, str "*) ", emitExp s e , str ")->payload"]
| emitPrim s (VOIDprim, [],_) = str "0 /* void value */"
| emitPrim s (MERGE_ROPEprim, [e],_) = seq [str (#prefix s ^ "merge_rope"), fArgs [emitExp s e]]
| emitPrim s _ = raise CodeGenBug
and addConsume s n = #consumeSizes s := IntListSet.add (!(#consumeSizes s),n)
......
......@@ -91,6 +91,7 @@ structure Imp = struct
| GET_CON_IDXprim
| GET_CON_ARGprim
| VOIDprim
| MERGE_ROPEprim
(* information on how to print primitives, the name is the C name
and the priority is the operator precedence, 0 if not infix *)
......@@ -128,6 +129,7 @@ structure Imp = struct
| prim_info GET_CON_IDXprim = { name = "__get_con_idx", prio = 0 }
| prim_info GET_CON_ARGprim = { name = "__get_con_arg", prio = 0 }
| prim_info VOIDprim = { name = "void", prio = 0 }
| prim_info MERGE_ROPEprim = { name = "merge-rope", prio = 0 }
(*
* fun f x =
......
......@@ -92,6 +92,7 @@ structure Primitives = struct
val content'''' = newFlow content
val inp = freshVar ()
val out = freshVar ()
val ropeVar = freshVar ()
(*create a type from two vectors to one vector, all of size s*)
fun func (a,b) = FUN ([a],b)
......@@ -242,7 +243,8 @@ structure Primitives = struct
flow = BD.meetVarImpliesVar (bvar content'''', bvar content') o
BD.meetVarImpliesVar (bvar content'''', bvar content''') o
BD.meetVarImpliesVar (bvar content'', bvar content')},
{name="void", ty=UNIT, flow = noFlow}
{name="void", ty=UNIT, flow = noFlow},
{name="merge-rope", ty=FUN([ropeVar],STRING), flow = noFlow}
]
val primitiveSizeConstraints =
......@@ -307,6 +309,7 @@ structure Primitives = struct
val oio = ftype [OBJvtype, INTvtype] OBJvtype
val oo = ftype [OBJvtype] OBJvtype
val oos = ftype [OBJvtype, OBJvtype] STRINGvtype
val os = ftype [OBJvtype] STRINGvtype
val o_ = ftype [] OBJvtype
val ssis = ftype [STRINGvtype, STRINGvtype, INTvtype] STRINGvtype
val si = ftype [STRINGvtype] INTvtype
......@@ -367,7 +370,8 @@ structure Primitives = struct
("puts", (t ~1, fn args => action (PRIexp (PRINTLNprim,sv,args)))),
("return", (t ~1, fn args => (case args of
[e] => action e
| _ => raise ImpPrimTranslationBug)))
| _ => raise ImpPrimTranslationBug))),
("merge-rope", (t 0, fn args => pr (MERGE_ROPEprim,os,args)))
]
end
......
......@@ -4,7 +4,7 @@ val generalize insn = let
val recordify mnemonic ua = {mnemonic=mnemonic, ua=ua}
val traversed = traverse recordify insn.insn
in
asm-insn insn.length (string-from-rope-lit traversed.mnemonic) (generalize-ua traversed.ua)
asm-insn insn.length (string-from-rope traversed.mnemonic) (generalize-ua traversed.ua)
end
val generalize-ua ua = case ua of
......@@ -15,7 +15,7 @@ val generalize-ua ua = case ua of
end
val generalize-opnd opnd = let
val generalize-register r = asm-reg (string-from-rope-lit (show/register r))
val generalize-register r = asm-reg (string-from-rope (show/register r))
in case opnd of
REG r: generalize-register r
| REGHL rhl: asm-composite (asm-opnds-more (generalize-register rhl.regh) (asm-opnds-one (generalize-register rhl.regl)))
......
......@@ -50,8 +50,9 @@ val from-string-lit s = RopeLeaf { rope-size = strlen s, rope-string = s }
# convert a string literal to a simple string, this function will fail
# for strings that are concatenated
val string-from-rope-lit r = case r of
val string-from-rope r = case r of
RopeLeaf l: l.rope-string
| RopeInner n : merge-rope r
end
val show-int s = from-string-lit (showint s)
......@@ -189,8 +190,8 @@ val &* c cs = case c of
end
val conf data short long = CONF
{ confShortName = string-from-rope-lit short,
confLongName = string-from-rope-lit long,
{ confShortName = string-from-rope short,
confLongName = string-from-rope long,
confData = data,
confNext = END }
......
......@@ -4,11 +4,11 @@ val generalize insn = let
val recordify mnemonic ua = {mnemonic=mnemonic, ua=ua}
val traversed = traverse recordify insn.insn
in
asm-insn-flags insn.length (string-from-rope-lit traversed.mnemonic) (generalize-fmt traversed.ua) (generalize-ua traversed.ua)
asm-insn-flags insn.length (string-from-rope traversed.mnemonic) (generalize-fmt traversed.ua) (generalize-ua traversed.ua)
end
val generalize-lvalue lval = let
val generalize-register r = asm-reg (string-from-rope-lit (show/register r))
val generalize-register r = asm-reg (string-from-rope (show/register r))
in case lval of
GPR r: generalize-register r
| FPR f: generalize-register f
......@@ -20,7 +20,7 @@ val generalize-rvalue rval =
| IMM i: generalize-immediate i
end
val generalize-format fmt = asm-ann-string (string-from-rope-lit (show/format fmt))
val generalize-format fmt = asm-ann-string (string-from-rope (show/format fmt))
val generalize-immediate i = let
val inner i sz = asm-bounded (asm-boundary-sz sz) (asm-imm (zx i))
......
......@@ -120,7 +120,7 @@ end
val rreil-convert-sem-id cbs id = case id of
FLOATING_FLAGS: cbs.sem_id.shared ((id_shared_enum id) + 0)
| VIRT_T t: cbs.sem_id.virt_t (t + 0)
| _: cbs.sem_id.arch (string-from-rope-lit (pretty-arch-id id))
| _: cbs.sem_id.arch (string-from-rope (pretty-arch-id id))
end
val rreil-convert-sem-address cbs address = cbs.sem_address.sem_address_ (address.size + 0) (rreil-convert-sem-linear cbs address.address)
......@@ -213,7 +213,7 @@ end
val rreil-convert-sem-exception cbs exception = case exception of
SEM_DIVISION_BY_ZERO: cbs.sem_exception.shared ((exception_enum exception) + 0)
| _: cbs.sem_exception.arch (string-from-rope-lit (pretty-arch-exception exception))
| _: cbs.sem_exception.arch (string-from-rope (pretty-arch-exception exception))
end
val rreil-convert-sem-stmt cbs stmt = case stmt of
......
......@@ -272,7 +272,7 @@ in
with-subscope bflop-inner
end
val prim-generic op lhs rhs = push (/PRIM (string-from-rope-lit op) lhs rhs)
val prim-generic op lhs rhs = push (/PRIM (string-from-rope op) lhs rhs)
val prim sz op lhs rhs = let
val unpack lins = case lins of
......@@ -288,7 +288,7 @@ val prim sz op lhs rhs = let
lhs <- unpack lhs;
rhs <- unpack rhs;
push (/PRIM (string-from-rope-lit op) lhs rhs)
push (/PRIM (string-from-rope op) lhs rhs)
end
in
with-subscope prim-inner
......
export generalize : (insndata) -> asm-insn
val generalize insn = asm-insn insn.length (string-from-rope-lit (pretty-mnemonic insn)) (generalize-ua (uarity-of insn.insn))
val generalize insn = asm-insn insn.length (string-from-rope (pretty-mnemonic insn)) (generalize-ua (uarity-of insn.insn))
val generalize-ua ua = case ua of
UA0: asm-opnds-none
......@@ -8,7 +8,7 @@ val generalize-ua ua = case ua of
| UA2 u: asm-opnds-more (generalize-opnd u.opnd1) (asm-opnds-one (generalize-opnd u.opnd2))
| UA3 u: asm-opnds-more (generalize-opnd u.opnd1) (asm-opnds-more (generalize-opnd u.opnd2) (asm-opnds-one (generalize-opnd u.opnd3)))
| UA4 u: asm-opnds-more (generalize-opnd u.opnd1) (asm-opnds-more (generalize-opnd u.opnd2) (asm-opnds-more (generalize-opnd u.opnd3) (asm-opnds-one (generalize-opnd u.opnd4))))
# | UAF u: asm-opnds-one (asm-copnd (string-from-rope-lit "flow") (asm-ropnd (asm-rel (generalize-opnd u.opnd1))))
# | UAF u: asm-opnds-one (asm-copnd (string-from-rope "flow") (asm-ropnd (asm-rel (generalize-opnd u.opnd1))))
end
......@@ -28,7 +28,7 @@ val generalize-immediate sz imm = asm-bounded (asm-boundary-sz sz) (asm-imm imm)
val generalize-register r = let
val rs = semantic-register-of r
in
asm-bounded (asm-boundary-sz-o rs.size rs.offset) (asm-reg (string-from-rope-lit (pretty-arch-id rs.id)))
asm-bounded (asm-boundary-sz-o rs.size rs.offset) (asm-reg (string-from-rope (pretty-arch-id rs.id)))
end
val generalize-memory m =
......
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