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
a842f8ca
Commit
a842f8ca
authored
Jun 28, 2012
by
mb0
Browse files
Foo.
parent
0c3e0b5c
Changes
29
Expand all
Hide whitespace changes
Inline
Side-by-side
detail/codegen/c0/runtime.c
View file @
a842f8ca
...
...
@@ -46,6 +46,34 @@ __obj __and (__obj a_, __obj b_) {
return
(
x
);
}
__obj
__add
(
__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
);
__INT_BEGIN
(
y
);
__INT_INIT
(
x
->
bv
.
vec
);
__INT_END
(
y
);
return
(
y
);
}
/* FIXME */
__obj
__zx
(
__obj
x
)
{
__LOCAL0
(
y
);
__INT_BEGIN
(
y
);
__INT_INIT
(
x
->
bv
.
vec
);
__INT_END
(
y
);
return
(
y
);
}
__obj
__concat
(
__obj
a_
,
__obj
b_
)
{
__word
a
=
a_
->
bv
.
vec
;
__word
b
=
b_
->
bv
.
vec
;
...
...
@@ -188,6 +216,35 @@ __word __decode (__obj (*f)(__obj,__obj), __char* blob, __word sz, __obj* insn)
}
}
__obj
__cont
(
__obj
env
,
__obj
f
)
{
__LOCAL
(
s
,
__CLOSURE_REF
(
env
,
1
));
__LOCAL0
(
k
);
__LABEL_BEGIN
(
k
);
__LABEL_INIT
(
__halt
);
__LABEL_END
(
k
);
__LOCAL0
(
envK
);
__CLOSURE_BEGIN
(
envK
,
1
)
__CLOSURE_ADD
(
k
);
__CLOSURE_END
(
envK
,
1
);
return
(
__INVOKE2
(
f
,
envK
,
s
));
}
__obj
__translate
(
__obj
(
*
f
)(
__obj
,
__obj
),
__obj
insn
)
{
__LOCAL0
(
s
);
__RECORD_BEGIN
(
s
,
0
);
__RECORD_END
(
s
,
0
);
__LOCAL0
(
k
);
__LABEL_BEGIN
(
k
);
__LABEL_INIT
(
__cont
);
__LABEL_END
(
k
);
__LOCAL0
(
envK
);
__CLOSURE_BEGIN
(
envK
,
2
)
__CLOSURE_ADD
(
k
);
__CLOSURE_ADD
(
s
);
__CLOSURE_END
(
envK
,
2
);
return
(
__CALL2
(
f
,
envK
,
insn
));
}
const
__char
*
__fieldName
(
__word
i
)
{
static
__char
*
unknown
=
(
__char
*
)
"<unknown>"
;
if
(
i
<
__NFIELDS
)
...
...
detail/codegen/c0/runtime.h
View file @
a842f8ca
...
...
@@ -390,6 +390,9 @@ __obj __unconsume(__obj);
__obj
__concat
(
__obj
,
__obj
);
__obj
__equal
(
__obj
,
__obj
);
__obj
__and
(
__obj
,
__obj
);
__obj
__sx
(
__obj
);
__obj
__zx
(
__obj
);
__obj
__add
(
__obj
,
__obj
);
__obj
__raise
(
__obj
);
__obj
__not
(
__obj
);
__obj
__isNil
(
__obj
);
...
...
@@ -401,6 +404,7 @@ int ___isNil(__obj);
__obj
__runWithState
(
__obj
(
*
)(
__obj
,
__obj
),
__obj
);
__obj
__eval
(
__obj
(
*
)(
__obj
,
__obj
),
__char
*
,
__word
);
__word
__decode
(
__obj
(
*
)(
__obj
,
__obj
),
__char
*
,
__word
,
__obj
*
);
__obj
__translate
(
__obj
(
*
)(
__obj
,
__obj
),
__obj
);
#endif
/* __RUNTIME_H */
...
...
detail/cps/cps-opt.sml
View file @
a842f8ca
...
...
@@ -15,6 +15,7 @@ structure Aux = struct
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
toString
sym
=
Layout
.
tostring
(
CPS
.
PP
.
var
sym
)
fun
failWithSymbol
msg
sym
=
msg
^
": "
^
Layout
.
tostring
(
CPS
.
PP
.
var
sym
)
...
...
@@ -866,7 +867,12 @@ structure Cost = struct
"binop"
,
"ternop"
,
"quaternop"
])
;
neverInline:=
Set
.
union
(
!neverInline
,
Set
.
fromList
(
map
Aux
.
get
[])))
;
neverInline:=
Set
.
union
(
!neverInline
,
Set
.
fromList
(
List
.
mapPartial
(
fn
x
=>
x
)
(
List
.
map
Aux
.
find
[]))))
val
allwaysInline
=
fn
f
=>
Set
.
member
(
!allwaysInline
,
f
)
fun
dontInline
f
=
neverInline
:=
Set
.
add
(
!neverInline
,
f
)
...
...
detail/cps/from-core.sml
View file @
a842f8ca
...
...
@@ -43,6 +43,39 @@ end = struct
val
not
=
get
"not"
val
raisee
=
get
"raise"
val
return
=
get
"return"
val
add
=
get
"+"
val
sx
=
get
"sx"
val
zx
=
get
"zx"
val
sx
=
let
val
x
=
fresh
"x"
val
primSx
=
get
"%sx"
val
body
=
PRI
(
primSx
,
[
x
])
in
(
sx
,
[
x
],
body
)
end
val
zx
=
let
val
x
=
fresh
"x"
val
primZx
=
get
"%zx"
val
body
=
PRI
(
primZx
,
[
x
])
in
(
zx
,
[
x
],
body
)
end
(*
val + a b = %add(a,b) *)
val
add
=
let
val
a
=
fresh
"a"
val
b
=
fresh
"b"
val
primAdd
=
get
"%add"
val
body
=
PRI
(
primAdd
,
[
a
,
b
])
in
(
add
,
[
a
,
b
],
body
)
end
(*
val and a b = %and(a,b) *)
val
andd
=
...
...
@@ -131,7 +164,7 @@ end = struct
(
unconsume
,
[
s
],
body
)
end
in
[
slice
,
consume
,
unconsume
,
andd
,
not
,
==
,
concat
,
raisee
]
[
slice
,
consume
,
unconsume
,
andd
,
not
,
==
,
concat
,
raisee
,
add
,
sx
,
zx
]
end
end
...
...
detail/parser/spec.g
View file @
a842f8ca
...
...
@@ -5,7 +5,6 @@
: KW_case ("case")
| KW_in ("in")
| KW_do ("do")
| KW_datatype ("datatype")
| KW_export ("export")
| KW_div ("div")
| KW_else ("else")
...
...
@@ -103,13 +102,10 @@ Program
Decl
: "granularity" "=" Int => (markDecl (FULL_SPAN, PT.GRANULARITYdecl Int))
| "export" "=" Qid* => (markDecl (FULL_SPAN, PT.EXPORTdecl Qid))
| "datatype" Name "=" ConDecls =>
(markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
| "type" Name "=" ConDecls => (markDecl (FULL_SPAN, PT.DATATYPEdecl (Name, ConDecls)))
| "type" Name "=" Ty => (markDecl (FULL_SPAN, PT.TYPEdecl (Name, Ty)))
| "val" Name Name* "=" Exp =>
(markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
| "val" Sym Name* "=" Exp =>
(markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
| "val" Name Name* "=" Exp => (markDecl (FULL_SPAN, PT.LETRECdecl (Name1, Name2, Exp)))
| "val" Sym Name* "=" Exp => (markDecl (FULL_SPAN, PT.LETRECdecl (Sym, Name, Exp)))
| "val" Name "[" DecodePat* "]" decl=
( "=" Exp =>
(PT.DECODEdecl (Name, DecodePat, Sum.INL Exp))
...
...
detail/parser/spec.g.sml
View file @
a842f8ca
...
...
@@ -49,12 +49,11 @@ SpecTokens = struct
|
KW_else
|
KW_div
|
KW_export
|
KW_datatype
|
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_datatype
,
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
]
fun
toString
tok
=
(
case
(
tok
)
...
...
@@ -106,7 +105,6 @@ SpecTokens = struct
|
(
KW_else
)
=>
"else"
|
(
KW_div
)
=>
"div"
|
(
KW_export
)
=>
"export"
|
(
KW_datatype
)
=>
"datatype"
|
(
KW_do
)
=>
"do"
|
(
KW_in
)
=>
"in"
|
(
KW_case
)
=>
"case"
...
...
@@ -161,7 +159,6 @@ SpecTokens = struct
|
(
KW_else
)
=>
false
|
(
KW_div
)
=>
false
|
(
KW_export
)
=>
false
|
(
KW_datatype
)
=>
false
|
(
KW_do
)
=>
false
|
(
KW_in
)
=>
false
|
(
KW_case
)
=>
false
...
...
@@ -229,17 +226,14 @@ fun Decl_PROD_1_ACT (EQ, Int, KW_granularity, EQ_SPAN : (Lex.pos * Lex.pos), Int
(
markDecl
(
FULL_SPAN
,
PT
.
GRANULARITYdecl
Int
))
fun
Decl_PROD_2_ACT
(
EQ
,
Qid
,
KW_export
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Qid_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_export_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
EXPORTdecl
Qid
))
fun
Decl_PROD_3_ACT
(
EQ
,
Name
,
KW_datatype
,
ConDecls
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_datatype_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
ConDecls_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
DATATYPEdecl
(
Name
,
ConDecls
)))
fun
Decl_PROD_3_ACT
(
EQ
,
Name
,
KW_type
,
ConDecls
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_type_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
ConDecls_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
DATATYPEdecl
(
Name
,
ConDecls
)))
fun
Decl_PROD_4_ACT
(
EQ
,
Ty
,
Name
,
KW_type
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Ty_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_type_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
TYPEdecl
(
Name
,
Ty
)))
fun
Decl_PROD_5_ACT
(
EQ
,
Exp
,
Name1
,
Name2
,
KW_val
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Exp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name1_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name2_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_val_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
LETRECdecl
(
Name1
,
Name2
,
Exp
)))
(
markDecl
(
FULL_SPAN
,
PT
.
LETRECdecl
(
Name1
,
Name2
,
Exp
)))
fun
Decl_PROD_6_ACT
(
EQ
,
Exp
,
Sym
,
Name
,
KW_val
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Exp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Sym_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_val_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
markDecl
(
FULL_SPAN
,
PT
.
LETRECdecl
(
Sym
,
Name
,
Exp
)))
(
markDecl
(
FULL_SPAN
,
PT
.
LETRECdecl
(
Sym
,
Name
,
Exp
)))
fun
Decl_PROD_7_SUBRULE_2_PROD_1_ACT
(
EQ
,
LB
,
RB
,
Exp
,
Name
,
DecodePat
,
KW_val
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
LB_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
RB_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Exp_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
DecodePat_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_val_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
))
=
(
PT
.
DECODEdecl
(
Name
,
DecodePat
,
Sum
.
INL
Exp
))
...
...
@@ -628,10 +622,6 @@ fun matchKW_export strm = (case (lex(strm))
of
(
Tok
.
KW_export
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
(*
end case *)
)
fun
matchKW_datatype
strm
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_datatype
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
(*
end case *)
)
fun
matchKW_do
strm
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_do
,
span
,
strm'
)
=>
((),
span
,
strm'
)
|
_
=>
fail
()
...
...
@@ -1698,13 +1688,13 @@ fun Decl_NT (strm) = let
FULL_SPAN
,
strm'
)
end
fun
Decl_PROD_3
(
strm
)
=
let
val
(
KW_
data
type_RES
,
KW_
data
type_SPAN
,
strm'
)
=
matchKW_
data
type
(
strm
)
val
(
KW_type_RES
,
KW_type_SPAN
,
strm'
)
=
matchKW_type
(
strm
)
val
(
Name_RES
,
Name_SPAN
,
strm'
)
=
Name_NT
(
strm'
)
val
(
EQ_RES
,
EQ_SPAN
,
strm'
)
=
matchEQ
(
strm'
)
val
(
ConDecls_RES
,
ConDecls_SPAN
,
strm'
)
=
ConDecls_NT
(
strm'
)
val
FULL_SPAN
=
(
#1
(
KW_
data
type_SPAN
),
#2
(
ConDecls_SPAN
))
val
FULL_SPAN
=
(
#1
(
KW_type_SPAN
),
#2
(
ConDecls_SPAN
))
in
(
UserCode
.
Decl_PROD_3_ACT
(
EQ_RES
,
Name_RES
,
KW_
data
type_RES
,
ConDecls_RES
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_
data
type_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
ConDecls_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
)),
(
UserCode
.
Decl_PROD_3_ACT
(
EQ_RES
,
Name_RES
,
KW_type_RES
,
ConDecls_RES
,
EQ_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
Name_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
KW_type_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
ConDecls_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
),
FULL_SPAN
:
(
Lex
.
pos
*
Lex
.
pos
)),
FULL_SPAN
,
strm'
)
end
fun
Decl_PROD_4
(
strm
)
=
let
...
...
@@ -1839,10 +1829,25 @@ fun Decl_NT (strm) = let
|
(
Tok
.
SYMBOL
(_),
_,
strm'
)
=>
Decl_PROD_6
(
strm
)
|
_
=>
fail
()
(*
end case *)
)
|
(
Tok
.
KW_datatype
,
_,
strm'
)
=>
Decl_PROD_3
(
strm
)
|
(
Tok
.
KW_type
,
_,
strm'
)
=>
(
case
(
lex
(
strm'
))
of
(
Tok
.
ID
(_),
_,
strm'
)
=>
(
case
(
lex
(
strm'
))
of
(
Tok
.
EQ
,
_,
strm'
)
=>
(
case
(
lex
(
strm'
))
of
(
Tok
.
CONS
(_),
_,
strm'
)
=>
Decl_PROD_3
(
strm
)
|
(
Tok
.
LCB
,
_,
strm'
)
=>
Decl_PROD_4
(
strm
)
|
(
Tok
.
ID
(_),
_,
strm'
)
=>
Decl_PROD_4
(
strm
)
|
(
Tok
.
POSINT
(_),
_,
strm'
)
=>
Decl_PROD_4
(
strm
)
|
(
Tok
.
NEGINT
(_),
_,
strm'
)
=>
Decl_PROD_4
(
strm
)
|
_
=>
fail
()
(*
end case *)
)
|
_
=>
fail
()
(*
end case *)
)
|
_
=>
fail
()
(*
end case *)
)
|
(
Tok
.
KW_granularity
,
_,
strm'
)
=>
Decl_PROD_1
(
strm
)
|
(
Tok
.
KW_export
,
_,
strm'
)
=>
Decl_PROD_2
(
strm
)
|
(
Tok
.
KW_type
,
_,
strm'
)
=>
Decl_PROD_4
(
strm
)
|
_
=>
fail
()
(*
end case *)
)
end
...
...
@@ -1866,8 +1871,7 @@ fun Program_NT (strm) = let
((
Decl_RES
),
FULL_SPAN
,
strm'
)
end
fun
Program_PROD_1_SUBRULE_1_PRED
(
strm
)
=
(
case
(
lex
(
strm
))
of
(
Tok
.
KW_datatype
,
_,
strm'
)
=>
true
|
(
Tok
.
KW_export
,
_,
strm'
)
=>
true
of
(
Tok
.
KW_export
,
_,
strm'
)
=>
true
|
(
Tok
.
KW_val
,
_,
strm'
)
=>
true
|
(
Tok
.
KW_granularity
,
_,
strm'
)
=>
true
|
(
Tok
.
KW_type
,
_,
strm'
)
=>
true
...
...
detail/parser/spec.l
View file @
a842f8ca
...
...
@@ -86,7 +86,6 @@
<INITIAL>"granularity" => (T.KW_granularity);
<INITIAL>"export" => (T.KW_export);
<INITIAL>"datatype" => (T.KW_datatype);
<INITIAL>"type" => (T.KW_type);
<INITIAL>"raise" => (T.KW_raise);
<INITIAL>"if" => (T.KW_if);
...
...
detail/parser/spec.l.sml
View file @
a842f8ca
This diff is collapsed.
Click to expand it.
detail/semantic/primitives.sml
View file @
a842f8ca
...
...
@@ -100,6 +100,10 @@ structure Primitives = struct
flow
=
noFlow
},
{
name
=
"%raise"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%and"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%sx"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%zx"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%add"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%sub"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%not"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%equal"
,
ty
=
UNIT
,
flow
=
noFlow
},
{
name
=
"%concat"
,
ty
=
UNIT
,
flow
=
noFlow
},
...
...
@@ -137,11 +141,13 @@ structure Primitives = struct
flow
=
BD
.
meetVarImpliesVar
(
bvar
g'
,
bvar
g
)
o
BD
.
meetVarImpliesVar
(
bvar
stateI'
,
bvar
stateI
)
o
BD
.
meetVarImpliesVar
(
bvar
stateI''
,
bvar
stateI
)
},
{
name
=
"+"
,
ty
=
vvv
s1
,
{
name
=
"+"
,
ty
=
FUN
([
ZENO
,
ZENO
],
ZENO
),
flow
=
noFlow
},
{
name
=
"-"
,
ty
=
FUN
([
ZENO
,
ZENO
],
ZENO
),
flow
=
noFlow
},
{
name
=
"++"
,
ty
=
vvv
s1
,
flow
=
BD
.
meetVarZero
(
bvar
s1
)},
{
name
=
"-"
,
ty
=
vvv
s2
,
{
name
=
"-
-
"
,
ty
=
vvv
s2
,
flow
=
BD
.
meetVarZero
(
bvar
s2
)},
{
name
=
"*"
,
ty
=
vvv
s3
,
{
name
=
"*
*
"
,
ty
=
vvv
s3
,
flow
=
BD
.
meetVarZero
(
bvar
s3
)},
{
name
=
"^"
,
ty
=
FUN
([
VEC
s4
,
VEC
s5
],
VEC
s6
),
flow
=
BD
.
meetVarZero
(
bvar
s4
)
o
...
...
@@ -159,9 +165,9 @@ structure Primitives = struct
flow
=
BD
.
meetVarZero
(
bvar
s10
)},
{
name
=
"not"
,
ty
=
vv
s11
,
flow
=
BD
.
meetVarZero
(
bvar
s11
)},
{
name
=
"s
igned
"
,
ty
=
func
(
VEC
s12
,
ZENO
),
{
name
=
"s
x
"
,
ty
=
func
(
VEC
s12
,
ZENO
),
flow
=
BD
.
meetVarZero
(
bvar
s12
)},
{
name
=
"
unsigned
"
,
ty
=
func
(
VEC
s13
,
ZENO
),
{
name
=
"
zx
"
,
ty
=
func
(
VEC
s13
,
ZENO
),
flow
=
BD
.
meetVarZero
(
bvar
s13
)},
{
name
=
"prefix"
,
ty
=
func
(
VEC
s14
,
VEC
s15
),
flow
=
BD
.
meetVarZero
(
bvar
s14
)
o
...
...
examples/0xd9-pattern
deleted
100644 → 0
View file @
0c3e0b5c
e0 1110 0000
/0 xx00 0xxx
e8 1110 1000
e9 1110 1001
ea 1110 1010
eb 1110 1011
ec 1110 1100
ed 1110 1101
ee 1110 1110
/5m 0010 1xxx
0110 1xxx
1010 1xxx
/4m 0010 0xxx
0110 0xxx
1010 0xxx
/7m 0011 1xxx
0111 1xxx
1011 1xxx
/2m 0001 0xxx
0101 0xxx
1001 0xxx
/2m 0001 1xxx
0101 1xxx
1001 1xxx
examples/arm.d
deleted
100644 → 0
View file @
0c3e0b5c
granularity
=
32
export
=
main
#
The
state
of
the
decode
monad
state
=
{
cond
:
cond
=
NONE
}
datatype
cond
EQ
|
NE
|
CS
|
CC
|
MI
|
PL
|
VS
|
VC
|
HI
|
LS
|
GE
|
LT
|
GT
|
LE
|
NONE
datatype
reg
=
R0
|
R1
|
R2
datatype
sty
=
LSL
|
LSR
|
ASR
|
ROR
datatype
op
=
|
IMM4
of
4
|
IMM12
of
12
|
REG
of
reg
datatype
triop
=
{
s
:
1
,
cond
:
cond
,
op1
:
op
,
op2
:
op
,
op3
:
op
}
val
reg
r
=
case
r
of
'
000
'
:
R0
|
'
001
'
:
R1
|
'
010
'
:
R2
#
and
so
on
...
datatype
insn
=
AND
of
triop
|
ADC
of
triop
val
cond
[
'
0000
'
]
=
update
@
{
cond
=
EQ
}
val
cond
[
'
0001
'
]
=
update
@
{
cond
=
NE
}
val
cond
[
'
0010
'
]
=
update
@
{
cond
=
CS
}
val
cond
[
'
0011
'
]
=
update
@
{
cond
=
CC
}
val
cond
[
'
0100
'
]
=
update
@
{
cond
=
MI
}
val
cond
[
'
0101
'
]
=
update
@
{
cond
=
PL
}
val
cond
[
'
0110
'
]
=
update
@
{
cond
=
VS
}
val
cond
[
'
0111
'
]
=
update
@
{
cond
=
VC
}
val
cond
[
'
1000
'
]
=
update
@
{
cond
=
HI
}
val
cond
[
'
1001
'
]
=
update
@
{
cond
=
LS
}
val
cond
[
'
1010
'
]
=
update
@
{
cond
=
GE
}
val
cond
[
'
1011
'
]
=
update
@
{
cond
=
LT
}
val
cond
[
'
1100
'
]
=
update
@
{
cond
=
GT
}
val
cond
[
'
1101
'
]
=
update
@
{
cond
=
LE
}
val
cond
[
'
1110
'
]
=
update
@
{
cond
=
NONE
}
val
shiftType
imm
ty
rm
=
LSL
val
shift
[
'
imm
:
5
ty
:
2
0
rm
:
4
'
]
=
update
@
{
shift
=
shiftType
imm
ty
rm
}
val
build
i
=
do
c
<-
query
$
cond
return
c
(
i
@
{
cond
=
c
})
val
buildWithShift
i
=
do
c
<-
query
$
cond
s
<-
query
$
shift
return
c
(
i
@
{
cond
=
c
,
shift
=
s
})
val
main
[
'
cond
0010000
s
:
1
rn
:
4
rd
:
4
imm
:
12
'
]
=
build
AND
{
s
=
s
,
op1
=
reg
rn
,
op2
=
reg
rd
,
op3
=
IMM12
imm
}
val
main
[
'
cond
0000101
s
:
1
rn
:
4
rd
:
4
shift
'
]
=
buildWithShift
ADC
{
s
=
s
,
op1
=
reg
rn
,
op2
=
reg
rd
}
examples/avr.d
View file @
a842f8ca
...
...
@@ -6,19 +6,19 @@ val decode = do
/
end
data
type
operand
=
type
operand
=
REG
of
register
|
REGHL
of
{
regh
:
register
,
regl
:
register
}
|
IMM6
of
6
type
binop
=
{
left
:
operand
,
right
:
operand
}
data
type
instruction
=
type
instruction
=
ADC
of
binop
|
ADD
of
binop
|
ADIW
of
binop
data
type
register
=
type
register
=
R0
|
R1
|
R2
...
...
examples/backtrack.d
deleted
100644 → 0
View file @
0c3e0b5c
granularity
=
8
export
=
decode
#
Optional
arguments
#
#
Limit
:
#
-
Restricts
the
maximium
size
of
the
decode
-
stream
#
Recursion
-
depth
:
#
-
Annotate
the
maximum
number
of
recursion
steps
for
#
the
given
decoder
.
This
way
,
we
can
compute
an
upper
#
bound
for
the
maximum
used
storage
for
the
emitted
AST
.
#
Additionally
,
the
decoder
may
fail
if
during
runtime
#
a
recrusion
depth
violation
occurs
.
#
#
limit
=
120
#
recursion
-
depth
=
main
=
4
val
set
-
opndsz
=
update
@
{
opndsz
=
'1'
}
val
set
-
repne
=
update
@
{
repne
=
'1'
}
val
set
-
rep
=
update
@
{
rep
=
'1'
}
val
set
-
CS
=
update
@
{
segment
=
'1'
}
val
set
-
DS
=
update
@
{
segment
=
'1'
}
val
set
-
ES
=
update
@
{
segment
=
'1'
}
val
set
-
FS
=
update
@
{
segment
=
'1'
}
val
set
-
GS
=
update
@
{
segment
=
'1'
}
val
set
-
SS
=
update
@
{
segment
=
'1'
}
val
set
-
lock
=
update
@
{
lock
=
'1'
}
val
set
-
addrsz
=
update
@
{
addrsz
=
'1'
}
##
Decoding
prefixes
val
failOver
first
second
=
do
update
@
{
tab
=
second
};
r
<-
first
;
update
@
{
tab
=
42
};
return
r
end
val
continue
=
do
t
<-
query
$
tab
;
update
@
{
tab
=
42
};
r
<-
t
;
update
@
{
tab
=
t
};
return
r
end
val
/
66
[]
=
continue
val
/
f2
[]
=
continue
val
/
f3
[]
=
continue
val
/
legacy
-
p
[
0x2e
]
=
do
clear
-
rex
;
set
-
CS
end
val
/
legacy
-
p
[
0x36
]
=
do
clear
-
rex
;
set
-
SS
end
val
/
legacy
-
p
[
0x3e
]
=
do
clear
-
rex
;
set
-
DS
end
val
/
legacy
-
p
[
0x26
]
=
do
clear
-
rex
;
set
-
ES
end
val
/
legacy
-
p
[
0x64
]
=
do
clear
-
rex
;
set
-
FS
end
val
/
legacy
-
p
[
0x65
]
=
do
clear
-
rex
;
set
-
GS
end
val
/
legacy
-
p
[
0x67
]
=
do
clear
-
rex
;
set
-
addrsz
end
val
/
legacy
-
p
[
0xf0
]
=
do
clear
-
rex
;
set
-
lock
end
val
/
rex
-
p
[
'
0100
w
:
1
r
:
1
x
:
1
b
:
1
'
]
=
update
@
{
rex
=
'1'
,
rexw
=
w
,
rexb
=
b
,
rexx
=
x
,
rexr
=
r
}
val
clear
-
rex
=
update
@
{
rexw
=
'0'
,
rexb
=
'0'
,
rexr
=
'0'
,
rexx
=
'0'
}
val
p64
[
0x66
]
=
do
set
-
opndsz
;
p
/
66
end
val
p64
[
0xf2
]
=
do
set
-
repne
;
p
/
f2
end
val
p64
[
0xf3
]
=
do
set
-
rep
;
p
/
f3
end
val
p64
[/
legacy
-
p
]
=
p64
val
p64
[/
rex
-
p
]
=
p64
val
p64
[]
=
/
val
p
/
66
[
0xf2
]
=
do
set
-
repne
;
p
/
66
/
f2
end
val
p
/
66
[
0xf3
]
=
do
set
-
rep
;
p
/
66
/
f3
end
val
p
/
66
[
0x66
]
=
do
set
-
opndsz
;
p
/
66
end
val
p
/
66
[/
legacy
-
p
]
=
p
/
66
val
p
/
66
[/
rex
-
p
]
=
p
/
66
val
p
/
66
[]
=
failOver
/
66
/
val
p
/
f2
[
0x66
]
=
do
set
-
opndsz
;
p
/
f2
/
66
end
val
p
/
f2
[
0xf2
]
=
do
set
-
repne
;
p
/
f2
end
val
p
/
f2
[
0xf3
]
=
do
set
-
rep
;
p
/
f2
/
f3
end
val
p
/
f2
[/
legacy
-
p
]
=
p
/
f2
val
p
/
f2
[/
rex
-
p
]
=
p
/
f2
val
p
/
f2
[]
=
failOver
/
f2
/
val
p
/
f3
[
0x66
]
=
do
set
-
opndsz
;
p
/
f3
/
66
end
val
p
/
f3
[
0xf2
]
=
do
set
-
repne
;
p
/
f3
/
f2
end
val
p
/
f3
[
0xf3
]
=
do
set
-
rep
;
p
/
f3
end
val
p
/
f3
[/
legacy
-
p
]
=
p
/
f3
val
p
/
f3
[/
rex
-
p
]
=
p
/
f3
val
p
/
f3
[]
=
failOver
/
f3
/