Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Tanzeem Haque
gdsl-toolkit
Commits
56f4e849
Commit
56f4e849
authored
Jul 06, 2012
by
mb0
Browse files
Merge upstream.
parent
e7421a30
Changes
21
Expand all
Hide whitespace changes
Inline
Side-by-side
detail/closure/from-cps.sml
View file @
56f4e849
...
...
@@ -9,7 +9,7 @@ end = struct
structure
FV
=
FreeVars
structure
FI
=
FunInfo
structure
Map
=
SymMap
structure
Set
=
Sym
Set
structure
Set
=
FreeVars
.
Set
structure
Clos
=
Closure
.
Stmt
val
closure
=
Atom
.
atom
"env"
...
...
detail/codegen/c0/c0.sml
View file @
56f4e849
...
...
@@ -53,13 +53,7 @@ structure PrettyC = struct
in
seq
[
str
"__INVOKE"
,
i
n
,
args
(
f::xs
)]
end
fun
fastinvoke
(
f
,
xs
)
=
let
val
n
=
List
.
length
xs
val
i
=
str
o
Int
.
toString
in
seq
[
str
"__CALL"
,
i
n
,
args
(
f::xs
)]
end
fun
fastinvoke
(
f
,
xs
)
=
seq
[
str
"__FCALL"
,
args
(
f::xs
)]
end
structure
C0Templates
=
struct
...
...
@@ -100,6 +94,7 @@ structure C = struct
fun
codegen
spec
=
let
open
Layout
Pretty
val
()
=
Mangle
.
reset
()
val
clos
=
Spec
.
get
#declarations
spec
val
exports
=
Spec
.
get
#exports
spec
fun
exported
f
=
...
...
detail/codegen/c0/runtime.c
View file @
56f4e849
...
...
@@ -56,6 +56,16 @@ __obj __add (__obj A, __obj B) {
return
(
x
);
}
__obj
__sub
(
__obj
A
,
__obj
B
)
{
__word
a
=
A
->
z
.
value
;
__word
b
=
B
->
z
.
value
;
__LOCAL0
(
x
);
__INT_BEGIN
(
x
);
__INT_INIT
(
a
-
b
);
__INT_END
(
x
);
return
(
x
);
}
/* FIXME */
__obj
__sx
(
__obj
x
)
{
__LOCAL0
(
y
);
...
...
@@ -185,7 +195,7 @@ __obj __runWithState (__obj (*f)(__obj,__obj), __obj s) {
__CLOSURE_BEGIN
(
envK
,
1
)
__CLOSURE_ADD
(
k
);
__CLOSURE_END
(
envK
,
1
);
return
(
__CALL
2
(
f
,
envK
,
s
));
return
(
__
F
CALL
(
f
,
envK
,
s
));
}
__obj
__eval
(
__obj
(
*
f
)(
__obj
,
__obj
),
__char
*
blob
,
__word
sz
)
{
...
...
@@ -226,7 +236,8 @@ __obj __cont (__obj env, __obj f) {
__CLOSURE_BEGIN
(
envK
,
1
)
__CLOSURE_ADD
(
k
);
__CLOSURE_END
(
envK
,
1
);
return
(
__INVOKE2
(
f
,
envK
,
s
));
__LOCAL
(
ff
,
__CLOSURE_REF
(
f
,
0
));
return
(
__INVOKE3
(
ff
,
f
,
envK
,
s
));
}
__obj
__translate
(
__obj
(
*
f
)(
__obj
,
__obj
),
__obj
insn
)
{
...
...
@@ -239,10 +250,11 @@ __obj __translate (__obj (*f)(__obj,__obj), __obj insn) {
__LABEL_END
(
k
);
__LOCAL0
(
envK
);
__CLOSURE_BEGIN
(
envK
,
2
)
__CLOSURE_ADD
(
k
);
__CLOSURE_ADD
(
s
);
__CLOSURE_ADD
(
k
);
__CLOSURE_END
(
envK
,
2
);
return
(
__CALL2
(
f
,
envK
,
insn
));
__LOCAL
(
ss
,
__FCALL
(
f
,
envK
,
insn
));
return
(
__RECORD_SELECT
(
ss
,
___1
));
}
const
__char
*
__fieldName
(
__word
i
)
{
...
...
detail/codegen/c0/runtime.h
View file @
56f4e849
...
...
@@ -37,24 +37,7 @@
#define __INVOKE7(o, closure, u, v, w, x, y, z)\
((__obj(*)(__obj,__obj,__obj,__obj,__obj,__obj,__obj))((o)->label.f))(closure, u, v, w, x, y, z)
#define __CALL1(f,x)\
f(x)
#define __CALL2(f,x,y)\
f(x,y)
#define __CALL3(f,x,y,z)\
f(x,y,z)
#define __CALL4(f,w,x,y,z)\
f(w,x,y,z)
#define __CALL5(f,v,w,x,y,z)\
f(v,w,x,y,z)
#define __CALL6(f,u,v,w,x,y,z)\
f(u,v,w,x,y,z)
#define __CALL7(f,t,u,v,w,x,y,z)\
f(t,u,v,w,x,y,z)
#define __CALL8(f,s,t,u,v,w,x,y,z)\
f(s,t,u,v,w,x,y,z)
#define __CALL9(f,r,s,t,u,v,w,x,y,z)\
f(r,s,t,u,v,w,x,y,z)
#define __FCALL(f,...) f(__VA_ARGS__)
/** ## Integers */
...
...
@@ -393,6 +376,7 @@ __obj __and(__obj,__obj);
__obj
__sx
(
__obj
);
__obj
__zx
(
__obj
);
__obj
__add
(
__obj
,
__obj
);
__obj
__sub
(
__obj
,
__obj
);
__obj
__raise
(
__obj
);
__obj
__not
(
__obj
);
__obj
__isNil
(
__obj
);
...
...
detail/codegen/codegen-mangle.sml
View file @
56f4e849
...
...
@@ -8,9 +8,14 @@ structure Mangle = struct
val
variables
=
SymbolTables
.
varTable
val
fields
=
SymbolTables
.
fieldTable
val
constructors
=
SymbolTables
.
conTable
val
names
=
ref
Map
.
empty
:
string
Map
.
map
ref
val
revnames
=
ref
Map
.
empty
:
string
Map
.
map
ref
val
stamp
=
ref
0
fun
reset
()
=
(
names
:=
Map
.
empty
;
revnames
:=
Map
.
empty
;
stamp
:=
0
)
fun
getStringOfPrim
sym
=
Atom
.
toString
(
VI
.
getAtom
(
!variables
,
sym
))
...
...
detail/codegen/js0/js0.sml
View file @
56f4e849
...
...
@@ -57,6 +57,7 @@ structure JS0 = struct
fun
codegen
cpsSpec
=
let
val
()
=
Mangle
.
reset
()
fun
id
s
=
Id
.
fromString
(
Mangle
.
apply
s
)
fun
field
f
=
PropertyName
.
fromString
(
Mangle
.
applyField
f
)
fun
fieldId
f
=
Id
.
fromString
(
Mangle
.
applyField
f
)
...
...
detail/common/pp.sml
View file @
56f4e849
...
...
@@ -26,6 +26,9 @@ structure Pretty = struct
fun
symset
item
t
=
L
.
listex
"{"
"}"
";"
(
List
.
map
item
(
SymSet
.
listItems
t
))
fun
symlistset
item
t
=
L
.
listex
"{"
"}"
";"
(
List
.
map
item
(
SymListSet
.
listItems
t
))
fun
pretty
layout
=
Layout
.
print
(
layout
,
print
)
fun
prettyTo
(
os
,
layout
)
=
Layout
.
print
(
layout
,
fn
s
=>
TextIO
.
output
(
os
,
s
))
end
detail/cps/cps-opt.sml
View file @
56f4e849
...
...
@@ -216,7 +216,7 @@ end
(*
Currently `FreeVars` is br0k3n considering mutually recursive functions *)
structure
FreeVars
=
struct
structure
Map
=
SymMap
structure
Set
=
SymSet
structure
Set
=
Sym
List
Set
type
t
=
Set
.
set
Map
.
map
val
freevars
=
ref
Map
.
empty
:
t
ref
...
...
@@ -386,7 +386,7 @@ structure FreeVars = struct
fun
layout
()
=
Pretty
.
symmap
{
key
=
CPS
.
PP
.
var
,
item
=
Pretty
.
symset
CPS
.
PP
.
var
}
(
!freevars
)
item
=
Pretty
.
sym
list
set
CPS
.
PP
.
var
}
(
!freevars
)
fun
dump
()
=
Pretty
.
prettyTo
(
TextIO
.
stdOut
,
layout
())
end
...
...
detail/cps/from-core.sml
View file @
56f4e849
...
...
@@ -44,6 +44,7 @@ end = struct
val
raisee
=
get
"raise"
val
return
=
get
"return"
val
add
=
get
"+"
val
sub
=
get
"-"
val
sx
=
get
"sx"
val
zx
=
get
"zx"
...
...
@@ -77,6 +78,18 @@ end = struct
(
add
,
[
a
,
b
],
body
)
end
(*
val - a b = %sub(a,b) *)
val
sub
=
let
val
a
=
fresh
"a"
val
b
=
fresh
"b"
val
primSub
=
get
"%sub"
val
body
=
PRI
(
primSub
,
[
a
,
b
])
in
(
sub
,
[
a
,
b
],
body
)
end
(*
val and a b = %and(a,b) *)
val
andd
=
let
...
...
@@ -164,7 +177,18 @@ end = struct
(
unconsume
,
[
s
],
body
)
end
in
[
slice
,
consume
,
unconsume
,
andd
,
not
,
==
,
concat
,
raisee
,
add
,
sx
,
zx
]
[
slice
,
consume
,
unconsume
,
andd
,
not
,
==
,
concat
,
raisee
,
add
,
sx
,
zx
,
sub
]
end
end
...
...
detail/desugar/inline-decode-patterns.sml
View file @
56f4e849
...
...
@@ -2,6 +2,18 @@
(*
*
* ## Inlining of decode patterns.
*)
structure
VarAux
=
struct
val
variables
=
SymbolTables
.
varTable
fun
atomOf
x
=
VarInfo
.
getAtom
(
!variables
,
x
)
fun
get
s
=
VarInfo
.
lookup
(
!variables
,
Atom
.
atom
s
)
fun
find
s
=
VarInfo
.
find
(
!variables
,
Atom
.
atom
s
)
fun
fresh
variable
=
let
val
(
tab
,
sym
)
=
VarInfo
.
fresh
(
!variables
,
variable
)
in
sym
before
SymbolTables
.
varTable
:=
tab
end
end
structure
ASTSubst
=
struct
val
empty
=
SymMap
.
empty
...
...
@@ -19,8 +31,8 @@ structure ASTSubst = struct
fun
copy
x
=
let
val
name
=
Aux
.
atomOf
x
val
x'
=
Aux
.
fresh
name
val
name
=
Var
Aux
.
atomOf
x
val
x'
=
Var
Aux
.
fresh
name
in
x'
end
...
...
detail/ml/smlnj/unsealed.cm
View file @
56f4e849
...
...
@@ -41,8 +41,10 @@ group is
../../semantic/primitives.sml
../../semantic/resolve-symbols.sml
../../semantic/resolve-type-info.sml
../../spec/core.sml
../../spec/spec.sml
../../desugar/desugar-control.sml
../../desugar/desugared-tree.sml
../../desugar/split-declarations.sml
...
...
@@ -53,16 +55,19 @@ group is
../../desugar/desugar-decode-syntax.sml
../../desugar/desugar-monadic-sequences.sml
../../desugar/desugar.sml
../../cps/cps.sml
../../cps/cps-control.sml
../../cps/from-core.sml
../../cps/cps-opt.sml
../../cps/mk-cps-pass.sml
../../cps/cps-passes.sml
../../closure/closure.sml
../../closure/closure-control.sml
../../closure/from-cps.sml
../../closure/closure-passes.sml
../../codegen/codegen-control.sml
../../codegen/codegen-mangle.sml
../../codegen/c0/c0.sml
...
...
detail/parser/spec.g
View file @
56f4e849
...
...
@@ -6,7 +6,6 @@
| KW_in ("in")
| KW_do ("do")
| KW_export ("export")
| KW_div ("div")
| KW_else ("else")
| KW_end ("end")
| KW_if ("if")
...
...
@@ -230,7 +229,6 @@ AExp
MExp
: SelectExp
(( "*" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.times))
| "div" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.div))
| "%" => (mark PT.MARKinfixop (FULL_SPAN, PT.OPinfixop Op.mod))
) ApplyExp =>
(SR, SelectExp))* =>
...
...
detail/parser/spec.g.sml
View file @
56f4e849
...
...
@@ -47,13 +47,12 @@ SpecTokens = struct
|
KW_if
|
KW_end
|
KW_else
|
KW_div
|
KW_export
|
KW_do
|
KW_in
|
KW_case
val
allToks
=
[
EOF
,
WILD
,
COLON
,
BAR
,
SEMI
,
COMMA
,
TILDE
,
SLASH
,
TIMES
,
MINUS
,
PLUS
,
CONCAT
,
RCB
,
LCB
,
RB
,
LB
,
RP
,
LP
,
DOT
,
TICK
,
EQ
,
BIND
,
SELECT
,
WITH
,
KW_or
,
KW_and
,
KW_type
,
KW_then
,
KW_raise
,
KW_granularity
,
KW_of
,
KW_mod
,
KW_val
,
KW_let
,
KW_if
,
KW_end
,
KW_else
,
KW_div
,
KW_export
,
KW_do
,
KW_in
,
KW_case
]
val
allToks
=
[
EOF
,
WILD
,
COLON
,
BAR
,
SEMI
,
COMMA
,
TILDE
,
SLASH
,
TIMES
,
MINUS
,
PLUS
,
CONCAT
,
RCB
,
LCB
,
RB
,
LB
,
RP
,
LP
,
DOT
,
TICK
,
EQ
,
BIND
,
SELECT
,
WITH
,
KW_or
,
KW_and
,
KW_type
,
KW_then
,
KW_raise
,
KW_granularity
,
KW_of
,
KW_mod
,
KW_val
,
KW_let
,
KW_if
,
KW_end
,
KW_else
,
KW_export
,
KW_do
,
KW_in
,
KW_case
]
fun
toString
tok
=
(
case
(
tok
)
...
...
@@ -103,7 +102,6 @@ SpecTokens = struct
|
(
KW_if
)
=>
"if"
|
(
KW_end
)
=>
"end"
|
(
KW_else
)
=>
"else"
|
(
KW_div
)
=>
"div"
|
(
KW_export
)
=>
"export"
|
(
KW_do
)
=>
"do"
|
(
KW_in
)
=>
"in"
...
...
@@ -157,7 +155,6 @@ SpecTokens = struct
|
(
KW_if
)
=>
false
|
(
KW_end
)
=>
false
|
(
KW_else
)
=>
false
|
(
KW_div
)
=>
false
|
(
KW_export
)
=>
false
|
(
KW_do
)
=>
false
|
(
KW_in
)
=>
false
...
...
@@ -333,9 +330,7 @@ fun AExp_PROD_1_ACT (SR, MExp, SR_SPAN : (Lex.pos * Lex.pos), MExp_SPAN : (Lex.p
mark
PT
.
MARKexp
(
FULL_SPAN
,
mkLBinExp
(
MExp
,
SR
)))
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_1_ACT
(
TIMES
,
SelectExp
,
TIMES_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
mark
PT
.
MARKinfixop
(
FULL_SPAN
,
PT
.
OPinfixop
Op
.
times
))
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT
(
SelectExp
,
KW_div
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_div_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
mark
PT
.
MARKinfixop
(
FULL_SPAN
,
PT
.
OPinfixop
Op
.
div
))
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3_ACT
(
SelectExp
,
KW_mod
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_mod_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT
(
SelectExp
,
KW_mod
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_mod_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
mark
PT
.
MARKinfixop
(
FULL_SPAN
,
PT
.
OPinfixop
Op
.
mod
))
fun
MExp_PROD_1_SUBRULE_1_PROD_1_ACT
(
SR
,
SelectExp
,
ApplyExp
,
SR_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
ApplyExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
...
...
@@ -614,10 +609,6 @@ fun matchKW_else strm = (case (lex(strm))
of
(
Tok
.
KW_else
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
(*
end case *)
)
fun
matchKW_div
strm
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_div
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
(*
end case *)
)
fun
matchKW_export
strm
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_export
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
...
...
@@ -947,8 +938,7 @@ and MonadicExp_NT (strm) = let
(
case
(
lex
(
strm
))
of
(
Tok
.
ID
(_),
_,
strm'
)
=>
(
case
(
lex
(
strm'
))
of
(
Tok
.
KW_div
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
|
(
Tok
.
KW_end
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
of
(
Tok
.
KW_end
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
|
(
Tok
.
KW_let
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
|
(
Tok
.
KW_mod
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
|
(
Tok
.
KW_and
,
_,
strm'
)
=>
MonadicExp_PROD_1
(
strm
)
...
...
@@ -1117,27 +1107,18 @@ and MExp_NT (strm) = let
FULL_SPAN
,
strm'
)
end
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2
(
strm
)
=
let
val
(
KW_div_RES
,
KW_div_SPAN
,
strm'
)
=
matchKW_div
(
strm
)
val
FULL_SPAN
=
(
#1
(
KW_div_SPAN
),
#2
(
KW_div_SPAN
))
in
(
UserCode
.
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2_ACT
(
SelectExp_RES
,
KW_div_RES
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_div_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
)),
FULL_SPAN
,
strm'
)
end
fun
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_3
(
strm
)
=
let
val
(
KW_mod_RES
,
KW_mod_SPAN
,
strm'
)
=
matchKW_mod
(
strm
)
val
FULL_SPAN
=
(
#1
(
KW_mod_SPAN
),
#2
(
KW_mod_SPAN
))
in
(
UserCode
.
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_
3
_ACT
(
SelectExp_RES
,
KW_mod_RES
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_mod_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
)),
(
UserCode
.
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_
2
_ACT
(
SelectExp_RES
,
KW_mod_RES
,
SelectExp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_mod_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
)),
FULL_SPAN
,
strm'
)
end
in
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_mod
,
_,
strm'
)
=>
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_
3
(
strm
)
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_
2
(
strm
)
|
(
Tok
.
TIMES
,
_,
strm'
)
=>
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_1
(
strm
)
|
(
Tok
.
KW_div
,
_,
strm'
)
=>
MExp_PROD_1_SUBRULE_1_PROD_1_SUBRULE_1_PROD_2
(
strm
)
|
_
=>
fail
()
(*
end case *)
)
end
...
...
@@ -1151,8 +1132,7 @@ and MExp_NT (strm) = let
FULL_SPAN
,
strm'
)
end
fun
MExp_PROD_1_SUBRULE_1_PRED
(
strm
)
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_div
,
_,
strm'
)
=>
true
|
(
Tok
.
KW_mod
,
_,
strm'
)
=>
true
of
(
Tok
.
KW_mod
,
_,
strm'
)
=>
true
|
(
Tok
.
TIMES
,
_,
strm'
)
=>
true
|
_
=>
false
(*
end case *)
)
...
...
detail/parser/spec.l
View file @
56f4e849
...
...
@@ -97,7 +97,6 @@
<INITIAL>"end" => (T.KW_end);
<INITIAL>"do" => (T.KW_do);
<INITIAL>"in" => (T.KW_in);
<INITIAL>"div" => (T.KW_div);
<INITIAL>"andalso" => (T.KW_and);
<INITIAL>"orelse" => (T.KW_or);
<INITIAL>"<-" => (T.BIND);
...
...
detail/parser/spec.l.sml
View file @
56f4e849
This diff is collapsed.
Click to expand it.
detail/semantic/symbol-table-type.sml
View file @
56f4e849
...
...
@@ -42,7 +42,7 @@ end
structure
SymbolTable
:>
SymbolTableSig
=
struct
val
concisePrint
:
bool
=
tru
e
val
concisePrint
:
bool
=
fals
e
structure
SymbolTable
=
IntRedBlackMap
structure
Reverse
=
AtomRedBlackMap
...
...
@@ -185,6 +185,7 @@ end
structure
SymMap
=
RedBlackMapFn
(
ord_symid
)
structure
SymSet
=
RedBlackSetFn
(
ord_symid
)
structure
SymListSet
=
ListSetFn
(
ord_symid
)
structure
SpanMap
=
RedBlackMapFn
(
struct
type
ord_key
=
Error
.
span
...
...
examples/rreil-stack.s
View file @
56f4e849
...
...
@@ -5,15 +5,24 @@ type sem_id =
ARCH_RAX
|
ARCH_RBX
|
ARCH_RCX
|
VIRT_EQ
|
VIRT_LES
|
VIRT_LEU
|
VIRT_LTS
|
VIRT_LTU
|
ARCH_RBP
|
ARCH_ZF
|
ARCH_CF
|
ARCH_SF
|
ARCH_OF
|
ARCH_PF
|
ARCH_AF
|
VIRT_EQ
#
==
|
VIRT_NEQ
#
/=
|
VIRT_LES
#
<=
s
|
VIRT_LEU
#
<=
u
|
VIRT_LTS
#
<
s
|
VIRT_LTU
#
<
u
|
VIRT_T
of
int
type
sem_arity1
=
{
size
:
int
,
opnd1
:
sem_linear
}
type
sem_arity2
=
{
size
:
int
,
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
type
sem_cmp
=
{
size
:
int
,
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
type
sem_address
=
{
size
:
int
,
address
:
sem_linear
}
type
sem_var
=
{
id
:
sem_id
,
offset
:
int
}
...
...
@@ -21,29 +30,40 @@ type sem_var = {id:sem_id, offset:int}
type
sem_linear
=
SEM_LIN_VAR
of
sem_var
|
SEM_LIN_IMM
of
{
imm
:
int
}
|
SEM_LIN_ADD
of
{
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
|
SEM_LIN_SUB
of
{
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
|
SEM_LIN_ADD
of
{
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
|
SEM_LIN_SUB
of
{
opnd1
:
sem_linear
,
opnd2
:
sem_linear
}
|
SEM_LIN_SCALE
of
{
imm
:
int
,
opnd
:
sem_linear
}
type
sem_op
=
SEM_LIN
of
sem_arity1
|
SEM_BSWAP
of
sem_arity1
|
SEM_MUL
of
sem_arity2
|
SEM_DIV
of
sem_arity2
|
SEM_BSWAP
of
sem_arity1
|
SEM_CMPEQ
of
sem_arity2
|
SEM_CMPLES
of
sem_arity2
|
SEM_CMPLEU
of
sem_arity2
|
SEM_CMPLTS
of
sem_arity2
|
SEM_CMPLTU
of
sem_arity2
|
SEM_DIVS
of
sem_arity2
|
SEM_MOD
of
sem_arity2
|
SEM_SHL
of
sem_arity2
|
SEM_SHR
of
sem_arity2
|
SEM_SHRS
of
sem_arity2
|
SEM_AND
of
sem_arity2
|
SEM_OR
of
sem_arity2
|
SEM_XOR
of
sem_arity2
|
SEM_SX
of
{
size
:
int
,
fromsize
:
int
,
opnd1
:
sem_linear
}
|
SEM_ZX
of
{
size
:
int
,
fromsize
:
int
,
opnd1
:
sem_linear
}
|
SEM_CMPEQ
of
sem_cmp
|
SEM_CMPNEQ
of
sem_cmp
|
SEM_CMPLES
of
sem_cmp
|
SEM_CMPLEU
of
sem_cmp
|
SEM_CMPLTS
of
sem_cmp
|
SEM_CMPLTU
of
sem_cmp
|
SEM_ARB
of
{
size
:
int
}
type
sem_stmt
=
SEM_ASSIGN
of
{
lhs
:
sem_var
,
rhs
:
sem_op
}
|
SEM_LOAD
of
{
lhs
:
sem_var
,
size
:
int
,
address
:
sem_address
}
|
SEM_STORE
of
{
address
:
sem_address
,
size
:
int
,
rhs
:
sem_
linear
}
|
SEM_STORE
of
{
address
:
sem_address
,
rhs
:
sem_
op
}
|
SEM_LABEL
of
{
id
:
int
}
|
SEM_
BRANCH_
TO_LABEL
of
{
target
:
int
}
|
SEM_
BRANCH
of
{
cond
:
sem_linear
,
size
:
int
,
target
:
sem_address
}
|
SEM_
IF_GO
TO_LABEL
of
{
cond
:
sem_linear
,
label
:
int
}
|
SEM_
IF_GOTO
of
{
cond
:
sem_linear
,
size
:
int
,
target
:
sem_address
}
|
SEM_CALL
of
{
cond
:
sem_linear
,
size
:
int
,
target
:
sem_address
}
|
SEM_RETURN
of
{
cond
:
sem_linear
,
size
:
int
,
target
:
sem_address
}
...
...
@@ -51,6 +71,21 @@ type sem_stmts =
SEM_CONS
of
{
hd
:
sem_stmt
,
tl
:
sem_stmts
}
|
SEM_NIL
type
sem_writeback
=
SEM_WRITE_VAR
of
{
size
:
int
,
id
:
sem_var
}
|
SEM_WRITE_MEM
of
{
size
:
int
,
address
:
sem_linear
}
val
revSeq
stmts
=
let
val
lp
stmt
acc
=
case
stmt
of
SEM_NIL
:
acc
|
SEM_CONS
x
:
lp
(
$tl
x
)
(
SEM_CONS
{
hd
=
$hd
x
,
tl
=
acc
})
end
in
lp
stmts
SEM_NIL
end
val
resultSize
op
=
case
op
of
SEM_CMPLES
x
:
1
...
...
@@ -67,8 +102,10 @@ val semanticRegisterOf r =
case
r
of
RAX
:
{
id
=
ARCH_RAX
,
offset
=
0
,
size
=
64
}
|
RBX
:
{
id
=
ARCH_RBX
,
offset
=
0
,
size
=
64
}
|
RBP
:
{
id
=
ARCH_RBP
,
offset
=
0
,
size
=
64
}
|
EAX
:
{
id
=
ARCH_RAX
,
offset
=
0
,
size
=
32
}
|
EBX
:
{
id
=
ARCH_RBX
,
offset
=
0
,
size
=
32
}
|
EBP
:
{
id
=
ARCH_RBP
,
offset
=
0
,
size
=
32
}
end
val
guessSizeOf
dst
/
src1
src2
=
...
...
@@ -82,18 +119,41 @@ val guessSizeOf dst/src1 src2 =
end
end
val
var
//0
x
=
SEM_LIN_VAR
{
id
=
x
,
offset
=
0
}
val
sizeOf
op
=
case
op
of
REG
r
:
return
(
$size
(
semanticRegisterOf
r
))
|
MEM
x
:
return
(
$sz
x
)
|
IMM8
i
:
return
(
8
)
|
IMM16
i
:
return
(
16
)
|
IMM32
i
:
return
(
32
)
|
IMM64
i
:
return
(
64
)
end
val
var
//0
x
=
{
id
=
x
,
offset
=
0
}
val
var
x
=
SEM_LIN_VAR
x
val
temp
=
do
val
mk
temp
=
do
t
<-
query
$tmp
;
t
'
<-
return
(
t
+
1
)
;
update
@
{
tmp
=
t
'};
return
{
id
=
VIRT_T
t
,
offset
=
0
}
end
val
mklabel
=
do
l
<-
query
$lab
;
l
'
<-
return
(
l
+
1
)
;
update
@
{
lab
=
l
'};
return
(
l
)
end
val
/
ASSIGN
a
b
=
SEM_ASSIGN
{
lhs
=
a
,
rhs
=
b
}
val
/
LOAD
sz
a
b
=
SEM_LOAD
{
lhs
=
a
,
size
=
sz
,
address
=
b
}
val
/
STORE
a
b
=
SEM_STORE
{
address
=
a
,
rhs
=
b
}
val
/
ADD
a
b
=
SEM_LIN_ADD
{
opnd1
=
a
,
opnd2
=
b
}
val
/
SUB
a
b
=
SEM_LIN_SUB
{
opnd1
=
a
,
opnd2
=
b
}
val
/
LABEL
l
=
SEM_LABEL
{
id
=
l
}
val
/
IFGOTOLABEL
c
l
=
SEM_IF_GOTO_LABEL
{
cond
=
c
,
label
=
l
}
val
/
GOTOLABEL
l
=
SEM_IF_GOTO_LABEL
{
cond
=
SEM_LIN_IMM
{
imm
=
1
},
label
=
l
}
val
push
insn
=
do
tl
<-
query
$stack
;
...
...
@@ -101,16 +161,38 @@ val push insn = do
end
val
mov
sz
a
b
=
push
(/
ASSIGN
a
(
SEM_LIN
{
size
=
sz
,
opnd1
=
b
}))
val
undef
sz
a
=
push
(/
ASSIGN
a
(
SEM_ARB
{
size
=
sz
}))
val
load
sz
a
psz
b
=
push
(/
LOAD
sz
a
{
size
=
psz
,
address
=
b
})
val
store
a
b
=
push
(/
STORE
a
b
)
val
add
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_LIN
{
size
=
sz
,
opnd1
=
/
ADD
b
c
}))
val
sub
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_LIN
{
size
=
sz
,
opnd1
=
/
SUB
b
c
}))
val
andb
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_AND
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
orb
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_OR
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
xorb
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_XOR
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
mul
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_MUL
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
div
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_DIV
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
divs
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_DIVS
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
shl
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_SHL
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
shr
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_SHR
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
shrs
sz
a
b
c
=
push
(/
ASSIGN
a
(
SEM_SHRS
{
size
=
sz
,
opnd1
=
b
,
opnd2
=
c
}))
val
bswap
sz
a
b
=
push
(/
ASSIGN
a
(
SEM_BSWAP
{
size
=
sz
,
opnd1
=
b
}))
val
movsx
szA
a
szB
b
=
push
(/
ASSIGN
a
(
SEM_SX
{
size
=
szA
,
fromsize
=
szB
,
opnd1
=
b
}))
val
movzx
szA
a
szB
b
=
push
(/
ASSIGN
a
(
SEM_ZX
{
size
=
szA
,
fromsize
=
szB
,
opnd1
=
b
}))