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
Armillon Damien
infosec-ecomp
Commits
9b110917
Commit
9b110917
authored
Apr 17, 2021
by
Armillon Damien
Browse files
midle struct
parent
4b249c26
Changes
14
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
9b110917
...
...
@@ -31,4 +31,7 @@ testFun: main.native
make
-C
tests
DIR
=
"type_funcall/*.e type_basic/*.e char/*.e"
testP
:
main.native
make
-C
tests
DIR
=
ptr/
*
.e
\ No newline at end of file
make
-C
tests
DIR
=
ptr/
*
.e
testS
:
main.native
make
-C
tests
DIR
=
structs/
*
.e
\ No newline at end of file
expr_grammar_action.g
View file @
9b110917
...
...
@@ -3,6 +3,7 @@ tokens SYM_LPARENTHESIS SYM_RPARENTHESIS SYM_LBRACE SYM_RBRACE
tokens SYM_ASSIGN SYM_SEMICOLON SYM_RETURN SYM_IF SYM_WHILE SYM_ELSE SYM_COMMA
tokens SYM_EQUALITY SYM_NOTEQ SYM_LT SYM_LEQ SYM_GT SYM_GEQ
tokens SYM_VOID SYM_CHAR SYM_INT SYM_CHARACTER<char> SYM_AMPERSAND
tokens SYM_STRUCT SYM_POINT
non-terminals S INSTR INSTRS LINSTRS ELSE EXPR FACTOR
non-terminals LPARAMS REST_PARAMS
non-terminals IDENTIFIER INTEGER
...
...
@@ -15,6 +16,7 @@ non-terminals BLOC
non-terminals IN_INSTR L_CALL_PARAMS REST_CALL_PARAMS FACTORS FACTOR_IDENTIFIER
non-terminals SYM_TYPE ASSIGN_EXPR FUNBODY
non-terminals VAR TYPE_PT
non-terminals STRUCTCONTENT STRUCTDEF DEFS STRUCTORFUN SYM_TYPE_NO_STRUCT DOTVAR
axiom S
{
...
...
@@ -28,15 +30,20 @@ axiom S
let resolve_associativity term other =
List.fold_left (fun acc (tag, tree) -> Node(tag,acc::tree)) term other
}
rules
S -> FUNDEFS SYM_EOF { Node (Tlistglobdef, $1) }
S -> DEFS SYM_EOF { Node (Tlistglobdef, $1) }
DEFS -> FUNDEF DEFS {Node(Tfundef, $1) :: $2}
DEFS -> STRUCTDEF DEFS {$1 :: $2}
DEFS -> {[]}
STRUCTDEF -> SYM_STRUCT SYM_IDENTIFIER STRUCTORFUN {$3 $2}
STRUCTORFUN -> SYM_LBRACE STRUCTCONTENT SYM_RBRACE SYM_SEMICOLON {fun name -> Node(Tstructdef, [StringLeaf(name);Node(Tstructcontent,$2)])}
STRUCTORFUN -> SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY {fun name -> Node(Tfundef,[Node(Tstruct,[StringLeaf(name)]);StringLeaf($1);Node(Tfunargs,$3);$5])}
STRUCTCONTENT -> SYM_TYPE SYM_IDENTIFIER SYM_SEMICOLON STRUCTCONTENT {Node(Tstructelement,[$1; StringLeaf($2)])::$4}
STRUCTCONTENT -> {[]}
BLOC -> SYM_LBRACE INSTRS SYM_RBRACE {Node(Tblock, $2)}
FUNDEFS -> {[]}
FUNDEFS -> FUNDEF FUNDEFS { (Node (Tfundef, $1)) :: $2 }
FUNDEF -> SYM_TYPE SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY { [$1; StringLeaf($2); (Node(Tfunargs, $4)); $6] }
FUNDEF -> SYM_TYPE_NO_STRUCT SYM_IDENTIFIER SYM_LPARENTHESIS LPARAMS SYM_RPARENTHESIS FUNBODY { [$1; StringLeaf($2); (Node(Tfunargs, $4)); $6] }
FUNBODY -> BLOC {$1}
FUNBODY -> SYM_SEMICOLON {NullLeaf}
LPARAMS -> {[]}
...
...
@@ -54,7 +61,7 @@ ASSIGN_EXPR -> {[NullLeaf]}
INSTRS -> {[]}
INSTRS -> INSTR INSTRS {$1::$2}
INSTR -> BLOC {$1}
INSTR -> VAR IN_INSTR {$2 $1}
INSTR -> VAR IN_INSTR {$2
(
$1
Tstructpoint )
}
INSTR -> SYM_TYPE SYM_IDENTIFIER ASSIGN_EXPR SYM_SEMICOLON {Node(Tassign, [Node(Tassignvar , (StringLeaf $2)::$3@[$1])])}
INSTR -> SYM_IF SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC ELSE {Node(Tif, $3::$5::$6)}
INSTR -> SYM_WHILE SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS BLOC {Node(Twhile, [$3;$5])}
...
...
@@ -87,13 +94,27 @@ FACTOR_IDENTIFIER -> {fun x -> x}
FACTOR_IDENTIFIER -> SYM_LPARENTHESIS L_CALL_PARAMS SYM_RPARENTHESIS {fun x -> Node(Tcall, x::$2)}
FACTOR -> SYM_INTEGER {IntLeaf($1)}
FACTOR -> SYM_CHARACTER {CharLeaf($1)}
FACTOR -> VAR FACTOR_IDENTIFIER {$2 $1}
FACTOR -> VAR FACTOR_IDENTIFIER {$2
(
$1
Tstructunfoll)
}
FACTOR -> SYM_LPARENTHESIS EXPR SYM_RPARENTHESIS {$2}
SYM_TYPE -> SYM_INT TYPE_PT {$2 (Node(Tint,[]))}
SYM_TYPE -> SYM_CHAR TYPE_PT { $2 (Node(Tchar,[]))}
SYM_TYPE -> SYM_VOID TYPE_PT {$2 (Node(Tvoid,[]))}
SYM_TYPE -> SYM_STRUCT TYPE_PT SYM_IDENTIFIER {$2 (Node(Tstruct,[StringLeaf($3)]))}
SYM_TYPE -> SYM_TYPE_NO_STRUCT {$1}
SYM_TYPE_NO_STRUCT -> SYM_INT TYPE_PT {$2 (Node(Tint,[]))}
SYM_TYPE_NO_STRUCT -> SYM_CHAR TYPE_PT { $2 (Node(Tchar,[]))}
SYM_TYPE_NO_STRUCT -> SYM_VOID TYPE_PT {$2 (Node(Tvoid,[]))}
TYPE_PT -> SYM_ASTERISK TYPE_PT {fun x -> $2 (Node(Tptr,[x]))}
TYPE_PT -> {fun x -> x}
VAR -> SYM_IDENTIFIER {StringLeaf($1)}
VAR -> SYM_ASTERISK VAR {Node(Tp,[$2])}
VAR -> SYM_AMPERSAND VAR {Node(Taddrof,[$2])}
VAR -> SYM_IDENTIFIER DOTVAR { fun x ->
let a = $2 x in
match a with
| [] -> StringLeaf($1)
| _ -> resolve_associativity (StringLeaf($1)) a
}
VAR -> SYM_ASTERISK VAR {fun x -> Node(Tp,[$2 x])}
VAR -> SYM_AMPERSAND VAR {fun x -> Node(Taddrof,[$2 x])}
DOTVAR -> SYM_POINT SYM_IDENTIFIER DOTVAR {fun x ->
let res = $3 x in
match res with
| [] -> (x,[StringLeaf $2])::[]
| _ -> (Tstructpoint,[StringLeaf $2])::res
}
DOTVAR -> {fun x -> []}
src/ast.ml
View file @
9b110917
...
...
@@ -31,10 +31,11 @@ type tag = Tassign | Tif | Twhile | Tblock | Treturn | Tprint
|
Tneg
|
Tlistglobdef
|
Tfundef
|
Tfunname
|
Tfunargs
|
Tfunbody
|
Tstructdef
|
Tstructcontent
|
Tstructelement
|
Tstructunfoll
|
Tstructpoint
|
Tassignvar
|
Targ
|
Tcall
|
Targs
|
Taddrof
|
Tp
|
Tvoid
|
Tint
|
Tchar
|
Tptr
|
Tvoid
|
Tint
|
Tchar
|
Tptr
|
Tstruct
type
tree
=
|
Node
of
tag
*
tree
list
|
StringLeaf
of
string
...
...
@@ -82,8 +83,15 @@ let string_of_tag = function
|
Tchar
->
"Tchar"
|
Tvoid
->
"Tvoid"
|
Tptr
->
"Tptr"
|
Tstruct
->
"Tstruct"
|
Taddrof
->
"Taddrof"
|
Tp
->
"Tp"
|
Tstructdef
->
"Tstructdef"
|
Tstructcontent
->
"Tstructcontent"
|
Tstructelement
->
"Tstructelement"
|
Tstructunfoll
->
"Tstructunfoll"
|
Tstructpoint
->
"Tstructpoint"
(* Écrit un fichier .dot qui correspond à un AST *)
...
...
@@ -129,13 +137,14 @@ let rec string_of_ast a =
let
rec
is_type
(
tr
:
tree
)
:
typ
res
=
match
tr
with
|
Node
(
t
,
st
)
when
List
.
length
st
<=
1
->
(
match
t
with
|
Tvoid
->
OK
(
Tvoid
)
|
Tint
->
OK
(
Tint
)
|
Tchar
->
OK
(
Tchar
)
|
Tptr
->
let
*
subtype
=
is_type
(
List
.
hd
st
)
in
|
Node
(
t
,
st
)
when
List
.
length
st
<=
1
->
(
match
t
,
st
with
|
Tvoid
,_
->
OK
(
Tvoid
)
|
Tint
,_
->
OK
(
Tint
)
|
Tchar
,_
->
OK
(
Tchar
)
|
Tptr
,
[
st
]
->
let
*
subtype
=
is_type
st
in
OK
(
Prog
.
Tptr
(
subtype
))
|
Tstruct
,
[
StringLeaf
name
]
->
OK
(
Prog
.
Tstruct
name
)
|
_
->
Error
"Not a type"
)
|
_
->
Error
(
Format
.
sprintf
"Not a type: %s"
(
string_of_ast
tr
))
\ No newline at end of file
src/cfg_gen.ml
View file @
9b110917
...
...
@@ -8,34 +8,34 @@ open Cfg_print
open
Options
open
Elang_gen
(* [cfg_expr_of_eexpr fun_typ funvartyp funvarinmem e] converts an [Elang.expr] into a [expr res]. This should
(* [cfg_expr_of_eexpr
struct_table
fun_typ funvartyp funvarinmem e] converts an [Elang.expr] into a [expr res]. This should
always succeed and be straightforward.
In later versions of this compiler, you will add more things to [Elang.expr]
but not to [Cfg.expr], hence the distinction.
*)
let
rec
cfg_expr_of_eexpr
fun_typ
(
funvartyp
:
(
string
,
typ
)
Hashtbl
.
t
)
(
funvarinmem
:
(
string
,
int
)
Hashtbl
.
t
)
(
e
:
Elang
.
expr
)
:
expr
res
=
let
rec
cfg_expr_of_eexpr
struct_table
fun_typ
(
funvartyp
:
(
string
,
typ
)
Hashtbl
.
t
)
(
funvarinmem
:
(
string
,
int
)
Hashtbl
.
t
)
(
e
:
Elang
.
expr
)
:
expr
res
=
match
e
with
|
Elang
.
Ebinop
(
b
,
e1
,
e2
)
->
let
*
t1
=
type_expr
funvartyp
fun_typ
e1
in
let
*
t2
=
type_expr
funvartyp
fun_typ
e2
in
let
*
value1
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e1
in
let
*
value2
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e2
in
let
*
t1
=
type_expr
struct_table
funvartyp
fun_typ
e1
in
let
*
t2
=
type_expr
struct_table
funvartyp
fun_typ
e2
in
let
*
value1
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e1
in
let
*
value2
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e2
in
(
match
t1
with
|
Tptr
t
->
let
*
size
=
size_type
t
in
let
*
size
=
size_type
t
struct_table
in
OK
(
Ebinop
(
b
,
value1
,
Ebinop
(
Emul
,
value2
,
Eint
size
)))
|
_
->
(
match
t2
with
|
Tptr
t
->
let
*
size
=
size_type
t
in
let
*
size
=
size_type
t
struct_table
in
OK
(
Ebinop
(
b
,
(
Ebinop
(
Emul
,
value1
,
Eint
size
))
,
value2
))
|
_
->
OK
(
Ebinop
(
b
,
value1
,
value2
))
))
|
Elang
.
Eunop
(
u
,
e
)
->
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
>>=
fun
ee
->
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
>>=
fun
ee
->
OK
(
Eunop
(
u
,
ee
))
|
Elang
.
Eint
i
->
OK
(
Eint
i
)
|
Elang
.
Echar
c
->
OK
(
Eint
(
Char
.
code
c
))
...
...
@@ -43,12 +43,12 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
(
match
Hashtbl
.
find_option
funvarinmem
v
with
|
Some
offset
->
let
*
mem_to_read
=
size_type
(
Hashtbl
.
find
funvartyp
v
)
in
let
*
mem_to_read
=
size_type
(
Hashtbl
.
find
funvartyp
v
)
struct_table
in
OK
(
Eload
(
Estk
offset
,
mem_to_read
))
|
None
->
OK
(
Evar
v
)
)
|
Elang
.
Ecall
(
name
,
elist
)
->
let
*
args_expr
=
list_map_res
(
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
)
elist
in
let
*
args_expr
=
list_map_res
(
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
)
elist
in
OK
(
Cfg
.
Ecall
(
name
,
args_expr
))
|
Elang
.
Eaddrof
(
e
)
->
(
match
e
with
...
...
@@ -60,15 +60,16 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
|
_
->
Error
"unauthorised operation: & on non var"
)
|
Elang
.
Eload
e
->
let
*
cfg_e
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
in
let
*
type_to_load
=
type_expr
funvartyp
fun_typ
e
in
let
*
cfg_e
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
in
let
*
type_to_load
=
type_expr
struct_table
funvartyp
fun_typ
e
in
(
match
type_to_load
with
|
Tptr
t
->
let
*
size
=
size_type
t
in
let
*
size
=
size_type
t
struct_table
in
OK
(
Eload
(
cfg_e
,
size
))
|
_
->
Error
"Can't load non pointer"
)
|
_
->
Error
"souffle dans mon trou"
(* [cfg_node_of_einstr fun_typ funvartyp funvarinmem next cfg succ i] builds the CFG node(s) that correspond
(* [cfg_node_of_einstr
struct_table
fun_typ funvartyp funvarinmem next cfg succ i] builds the CFG node(s) that correspond
to the E instruction [i].
[cfg] is the current state of the control-flow graph.
...
...
@@ -83,55 +84,56 @@ let rec cfg_expr_of_eexpr fun_typ (funvartyp: (string, typ) Hashtbl.t) (funvarin
Hint: several nodes may be generated for a single E instruction.
*)
let
rec
cfg_node_of_einstr
fun_typ
funvartyp
(
funvarinmem
:
(
string
,
int
)
Hashtbl
.
t
)
(
next
:
int
)
(
cfg
:
(
int
,
cfg_node
)
Hashtbl
.
t
)
let
rec
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
(
funvarinmem
:
(
string
,
int
)
Hashtbl
.
t
)
(
next
:
int
)
(
cfg
:
(
int
,
cfg_node
)
Hashtbl
.
t
)
(
succ
:
int
)
(
i
:
instr
)
:
(
int
*
int
)
res
=
match
i
with
|
Elang
.
Iassign
(
v
,
e
)
->
let
*
value
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
in
let
*
value
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
in
(
match
Hashtbl
.
find_option
funvarinmem
v
with
|
Some
addr
->
let
type_var
=
Hashtbl
.
find
funvartyp
v
in
let
*
size_write
=
size_type
type_var
in
let
*
size_write
=
size_type
type_var
struct_table
in
Hashtbl
.
replace
cfg
next
(
Cstore
(
Estk
addr
,
value
,
size_write
,
succ
));
OK
(
next
,
next
+
1
)
|
None
->
let
*
e
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
in
let
*
e
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
in
Hashtbl
.
replace
cfg
next
(
Cassign
(
v
,
e
,
succ
));
OK
(
next
,
next
+
1
))
|
Elang
.
Iif
(
c
,
ithen
,
ielse
)
->
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
c
>>=
fun
c
->
cfg_node_of_einstr
fun_typ
funvartyp
funvarinmem
next
cfg
succ
ithen
>>=
fun
(
nthen
,
next
)
->
cfg_node_of_einstr
fun_typ
funvartyp
funvarinmem
next
cfg
succ
ielse
>>=
fun
(
nelse
,
next
)
->
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
c
>>=
fun
c
->
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
funvarinmem
next
cfg
succ
ithen
>>=
fun
(
nthen
,
next
)
->
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
funvarinmem
next
cfg
succ
ielse
>>=
fun
(
nelse
,
next
)
->
Hashtbl
.
replace
cfg
next
(
Ccmp
(
c
,
nthen
,
nelse
));
OK
(
next
,
next
+
1
)
|
Elang
.
Iwhile
(
c
,
i
)
->
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
c
>>=
fun
c
->
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
c
>>=
fun
c
->
let
(
cmp
,
next
)
=
(
next
,
next
+
1
)
in
cfg_node_of_einstr
fun_typ
funvartyp
funvarinmem
next
cfg
cmp
i
>>=
fun
(
nthen
,
next
)
->
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
funvarinmem
next
cfg
cmp
i
>>=
fun
(
nthen
,
next
)
->
Hashtbl
.
replace
cfg
cmp
(
Ccmp
(
c
,
nthen
,
succ
));
OK
(
cmp
,
next
+
1
)
|
Elang
.
Iblock
il
->
List
.
fold_right
(
fun
i
acc
->
acc
>>=
fun
(
succ
,
next
)
->
cfg_node_of_einstr
fun_typ
funvartyp
funvarinmem
next
cfg
succ
i
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
funvarinmem
next
cfg
succ
i
)
il
(
OK
(
succ
,
next
))
|
Elang
.
Ireturn
e
->
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
>>=
fun
e
->
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
>>=
fun
e
->
Hashtbl
.
replace
cfg
next
(
Creturn
e
);
OK
(
next
,
next
+
1
)
|
Elang
.
Iprint
e
->
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e
>>=
fun
e
->
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e
>>=
fun
e
->
Hashtbl
.
replace
cfg
next
(
Cprint
(
e
,
succ
));
OK
(
next
,
next
+
1
)
|
Elang
.
Icall
(
name
,
elist
)
->
let
*
args_expr
=
list_map_res
(
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
)
elist
in
let
*
args_expr
=
list_map_res
(
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
)
elist
in
Hashtbl
.
replace
cfg
next
(
Ccall
(
name
,
args_expr
,
succ
));
OK
(
next
,
next
+
1
)
|
Elang
.
Istore
(
e1
,
e2
)
->
let
*
addr
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e1
in
let
*
value
=
cfg_expr_of_eexpr
fun_typ
funvartyp
funvarinmem
e2
in
let
*
t
=
type_expr
funvartyp
fun_typ
e1
in
let
*
size_write
=
size_type
t
in
let
*
addr
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e1
in
let
*
value
=
cfg_expr_of_eexpr
struct_table
fun_typ
funvartyp
funvarinmem
e2
in
let
*
t
=
type_expr
struct_table
funvartyp
fun_typ
e1
in
let
*
size_write
=
size_type
t
struct_table
in
Hashtbl
.
replace
cfg
next
(
Cstore
(
addr
,
value
,
size_write
,
succ
));
OK
(
next
,
next
+
1
)
|
_
->
Error
"soufle dans mon trou"
...
...
@@ -156,10 +158,10 @@ let rec reachable_nodes n (cfg: (int,cfg_node) Hashtbl.t) =
in
reachable_aux
n
Set
.
empty
(* [cfg_fun_of_efun f] builds the CFG for E function [f]. *)
let
cfg_fun_of_efun
fun_typ
{
funargs
;
funbody
;
funvartyp
;
funvarinmem
;
funstksz
}
=
let
cfg_fun_of_efun
struct_table
fun_typ
{
funargs
;
funbody
;
funvartyp
;
funvarinmem
;
funstksz
}
=
let
cfg
=
Hashtbl
.
create
17
in
Hashtbl
.
replace
cfg
0
(
Creturn
(
Eint
0
));
cfg_node_of_einstr
fun_typ
funvartyp
funvarinmem
1
cfg
0
funbody
>>=
fun
(
node
,
_
)
->
cfg_node_of_einstr
struct_table
fun_typ
funvartyp
funvarinmem
1
cfg
0
funbody
>>=
fun
(
node
,
_
)
->
(* remove unreachable nodes *)
let
r
=
reachable_nodes
node
cfg
in
Hashtbl
.
filteri_inplace
(
fun
k
_
->
Set
.
mem
k
r
)
cfg
;
...
...
@@ -169,20 +171,21 @@ let cfg_fun_of_efun fun_typ { funargs; funbody; funvartyp; funvarinmem; funstksz
cfgfunstksz
=
funstksz
;
}
let
cfg_gdef_of_edef
fun_typ
gd
=
let
cfg_gdef_of_edef
struct_table
fun_typ
gd
=
match
gd
with
Gfun
f
->
cfg_fun_of_efun
fun_typ
f
>>=
fun
f
->
OK
(
Gfun
f
)
Gfun
f
->
cfg_fun_of_efun
struct_table
fun_typ
f
>>=
fun
f
->
OK
(
Gfun
f
)
let
cfg_prog_of_eprog
(
ep
:
eprog
)
:
cfg_fun
prog
res
=
let
fun_typ
=
Hashtbl
.
create
(
3
+
(
List
.
length
ep
))
in
let
(
fun_list
,
struct_table
)
=
ep
in
let
fun_typ
=
Hashtbl
.
create
(
3
+
(
List
.
length
fun_list
))
in
List
.
iter
(
fun
(
name
,
pro
)
->
match
pro
with
|
Gfun
f
->
Hashtbl
.
replace
fun_typ
name
((
snd
(
List
.
split
f
.
funargs
))
,
f
.
funrettype
);
)
ep
;
)
fun_list
;
Hashtbl
.
replace
fun_typ
"print"
([
Tint
]
,
Tvoid
);
Hashtbl
.
replace
fun_typ
"print_int"
([
Tint
]
,
Tvoid
);
Hashtbl
.
replace
fun_typ
"print_char"
([
Tchar
]
,
Tvoid
);
assoc_map_res
(
fun
fname
->
cfg_gdef_of_edef
fun_typ
)
ep
assoc_map_res
(
fun
fname
->
cfg_gdef_of_edef
struct_table
fun_typ
)
fun_list
let
pass_cfg_gen
ep
=
match
cfg_prog_of_eprog
ep
with
...
...
src/elang.ml
View file @
9b110917
...
...
@@ -16,6 +16,7 @@ type expr =
|
Ecall
of
string
*
expr
list
|
Eaddrof
of
expr
|
Eload
of
expr
|
Egetfield
of
expr
*
string
type
instr
=
|
Iassign
of
string
*
expr
...
...
@@ -26,6 +27,7 @@ type instr =
|
Iprint
of
expr
|
Icall
of
string
*
expr
list
|
Istore
of
expr
*
expr
|
Isetfield
of
expr
*
string
*
expr
type
efun
=
{
funargs
:
(
string
*
typ
)
list
;
...
...
@@ -36,4 +38,4 @@ type efun = {
funstksz
:
int
}
type
eprog
=
efun
prog
type
eprog
=
efun
prog
*
(
string
,
(
string
*
typ
)
list
)
Hashtbl
.
t
src/elang_gen.ml
View file @
9b110917
...
...
@@ -50,19 +50,23 @@ let binop_of_tag =
|
_
->
assert
false
let
rec
type_expr
let
rec
type_expr
struct_table
(
typ_var
:
(
string
,
typ
)
Hashtbl
.
t
)
(
typ_fun
:
(
string
,
typ
list
*
typ
)
Hashtbl
.
t
)
(
e
:
expr
)
:
typ
res
=
match
e
with
|
Ebinop
(
op
,
e1
,
e2
)
->
type_expr
typ_var
typ_fun
e1
|
Eunop
(
op
,
e
)
->
type_expr
typ_var
typ_fun
e
|
Ebinop
(
op
,
e1
,
e2
)
->
type_expr
struct_table
typ_var
typ_fun
e1
|
Eunop
(
op
,
e
)
->
type_expr
struct_table
typ_var
typ_fun
e
|
Eint
n
->
OK
Tint
|
Echar
c
->
OK
Tchar
|
Evar
v
->
(
match
Hashtbl
.
find_option
typ_var
v
with
|
Some
t
->
OK
t
|
Some
t
->
(
match
t
with
|
Tstruct
name
->
OK
(
Tptr
t
)
|
_
->
OK
t
)
|
None
->
Error
(
Format
.
sprintf
"variable %s not found (unknown type)"
v
)
)
|
Ecall
(
func
,
el
)
->
...
...
@@ -71,13 +75,19 @@ let rec type_expr
|
None
->
Error
(
Format
.
sprintf
"function %s not found (unknown type)"
func
)
)
|
Eaddrof
(
e
)
->
let
*
type_e
=
type_expr
typ_var
typ_fun
e
in
let
*
type_e
=
type_expr
struct_table
typ_var
typ_fun
e
in
OK
(
Tptr
type_e
)
|
Eload
e
->
let
*
type_e
=
type_expr
typ_var
typ_fun
e
in
match
type_e
with
let
*
type_e
=
type_expr
struct_table
typ_var
typ_fun
e
in
(
match
type_e
with
|
Tptr
t
->
OK
t
|
_
->
Error
"Can't deference a non pointer type"
|
_
->
Error
"Can't deference a non pointer type"
)
|
Egetfield
(
e
,
s
)
->
let
*
et
=
type_expr
struct_table
typ_var
typ_fun
e
in
match
et
with
|
Tptr
Tstruct
name
->
field_type
struct_table
name
s
|
_
->
Error
"Can only get field of struct"
let
are_types_compatible
(
t1
:
typ
)
(
t2
:
typ
)
:
typ
res
=
match
t1
with
...
...
@@ -87,11 +97,13 @@ let are_types_compatible (t1: typ) (t2:typ): typ res =
|
Tint
|
Tchar
->
OK
(
t1
)
|
_
->
Error
(
Format
.
sprintf
"Incompatible type %s %s"
(
string_of_typ
t1
)
(
string_of_typ
t2
))
)
|
Tptr
Tstruct
name
->
if
t2
=
Tstruct
name
||
t2
=
Tptr
(
Tstruct
name
)
then
OK
(
t1
)
else
Error
(
Printf
.
sprintf
"Incompatible type %s %s"
(
string_of_typ
t1
)
(
string_of_typ
t2
))
|
Tstruct
name
->
if
t2
=
Tstruct
name
||
t2
=
Tptr
(
Tstruct
name
)
then
OK
(
t1
)
else
Error
(
Printf
.
sprintf
"Incompatible type %s %s"
(
string_of_typ
t1
)
(
string_of_typ
t2
))
|
Tptr
t
->
(
match
t2
with
|
Tptr
t'
->
if
t
=
t'
then
OK
(
t
)
else
Error
"Pointer of two different types"
|
Tint
->
OK
(
Tint
)
|
_
->
Error
"Incompatible type: pointers are integers"
match
t2
with
|
Tptr
t'
->
if
t
=
t'
then
OK
(
t
)
else
Error
"Pointer of two different types"
|
Tint
->
OK
(
Tint
)
|
_
->
Error
"Incompatible type: pointers are integers"
)
|
_
->
Error
(
Format
.
sprintf
"Incompatible type %s %s"
(
string_of_typ
t1
)
(
string_of_typ
t2
))
...
...
@@ -109,7 +121,6 @@ let type_expr_binop (op:binop) (t1: typ) (t2:typ): typ res =
)
|
_
->
error
)
|
Tptr
t'
->
(
match
t2
with
|
Tint
|
Tchar
when
op
=
Eadd
||
op
=
Esub
->
OK
t1
...
...
@@ -118,7 +129,7 @@ let type_expr_binop (op:binop) (t1: typ) (t2:typ): typ res =
|
Eclt
|
Ecle
|
Ecgt
|
Ecge
|
Eceq
|
Ecne
->
OK
Tint
|
_
->
error
)
|
_
->
error
|
_
->
error
)
|
_
->
error
...
...
@@ -134,6 +145,7 @@ let rec addr_taken_expr (e: expr) : string Set.t =
match
e
with
|
Ebinop
(
_
,
e1
,
e2
)
->
Set
.
union
(
addr_taken_expr
e1
)
(
addr_taken_expr
e2
)
|
Eload
(
e
)
|
Egetfield
(
e
,_
)
|
Eunop
(
_
,
e
)
->
addr_taken_expr
e
|
Ecall
(
_
,
el
)
->
List
.
fold_left
(
fun
acc
e
->
Set
.
union
acc
(
addr_taken_expr
e
))
Set
.
empty
el
|
Eaddrof
(
Evar
(
v
))
->
Set
.
singleton
v
...
...
@@ -151,15 +163,21 @@ let rec addr_taken_instr (i: instr) : string Set.t =
|
Ireturn
e
->
addr_taken_expr
e
|
Iprint
e
->
addr_taken_expr
e
|
Icall
(
_
,
el
)
->
List
.
fold_left
(
fun
acc
e
->
Set
.
union
acc
(
addr_taken_expr
e
))
Set
.
empty
el
|
Isetfield
(
e1
,_,
e2
)
|
Istore
(
e1
,
e2
)
->
Set
.
union
(
addr_taken_expr
e1
)(
addr_taken_expr
e2
)
let
gen_funvarinmem
i
funvartyp
:
((
string
,
int
)
Hashtbl
.
t
*
int
)
res
=
let
gen_funvarinmem
i
funvartyp
struct_table
:
((
string
,
int
)
Hashtbl
.
t
*
int
)
res
=
let
var_in_mem
=
addr_taken_instr
i
in
let
var_in_mem
=
Hashtbl
.
fold
(
fun
name
typv
acc
->
match
typv
with
|
Tstruct
_
->
Set
.
union
(
Set
.
singleton
name
)
acc
|
_
->
acc
)
funvartyp
var_in_mem
in
Set
.
fold
(
fun
var
acc
->
let
*
(
table
,
size
)
=
acc
in
let
var_typ
=
Hashtbl
.
find
funvartyp
var
in
let
*
offset
=
size_type
var_typ
in
let
*
offset
=
size_type
var_typ
struct_table
in
Hashtbl
.
replace
table
var
size
;
OK
(
table
,
size
+
offset
)
)
var_in_mem
(
OK
(
Hashtbl
.
create
(
Set
.
cardinal
var_in_mem
)
,
0
))
...
...
@@ -168,7 +186,9 @@ let gen_funvarinmem i funvartyp: ((string, int )Hashtbl.t * int) res=
the tree is not well-formed, fails with an [Error] message. *)
let
rec
make_eexpr_of_ast
(
a
:
tree
)
(
typ_var
:
(
string
,
typ
)
Hashtbl
.
t
)
(
typ_fun
:
(
string
,
typ
list
*
typ
)
Hashtbl
.
t
)
:
(
expr
*
typ
)
res
=
(
typ_fun
:
(
string
,
typ
list
*
typ
)
Hashtbl
.
t
)
(
struct_table
:
(
string
,
(
string
*
Prog
.
typ
)
list
)
Hashtbl
.
t
)
:
(
expr
*
typ
)
res
=
let
res
=
match
a
with
|
Node
(
Tcall
,
StringLeaf
(
name
)
::
r
)
->
...
...
@@ -176,51 +196,76 @@ let rec make_eexpr_of_ast (a: tree)
|
Node
(
Targs
,
l
)
::
[]
->
l
|
_
->
[]
)
in
list_map_res
(
fun
e
->
make_eexpr_of_ast
e
typ_var
typ_fun
)
args_list
>>=
fun
args_expr
->
list_map_res
(
fun
e
->
make_eexpr_of_ast
e
typ_var
typ_fun
struct_table
)
args_list
>>=
fun
args_expr
->
let
(
args_expr
,
args_t
)
=
List
.
split
args_expr
in
let
returned_expression
=
Ecall
(
name
,
args_expr
)
in
let
(
args_typ
,_
)
=
Hashtbl
.
find
typ_fun
name
in
if
(
List
.
length
args_typ
)
!=
(
List
.
length
args_t
)
then
Error
(
Format
.
sprintf
"%s called with %d instead of %d"
name
(
List
.
length
args_t
)
(
List
.
length
args_typ
)
)
else
let
does_args_typ_match
=
List
.
for_all2
(
=
)
args_typ
args_t
in
let
does_args_typ_match
=
List
.
for_all2
(
fun
t1
t2
->
match
are_types_compatible
t1
t2
with
|
OK
_
->
true
|
Error
_
->
false
)
args_typ
args_t
in
if
does_args_typ_match
then
let
*
t
=
type_expr
typ_var
typ_fun
returned_expression
in
let
*
t
=
type_expr
struct_table
typ_var
typ_fun
returned_expression
in
OK
(
returned_expression
,
t
)
else
Error
(
Format
.
sprintf
"arguments types does not match in expression calling %s"
name
)
|
Node
(
t
,
[
e1
;
e2
])
when
tag_is_binop
t
->
make_eexpr_of_ast
e1
typ_var
typ_fun
>>=
fun
(
expr1
,
t1
)
->
make_eexpr_of_ast
e2
typ_var
typ_fun
>>=
fun
(
expr2
,
t2
)
->
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
>>=
fun
(
expr1
,
t1
)
->
make_eexpr_of_ast
e2
typ_var
typ_fun
struct_table
>>=
fun
(
expr2
,
t2
)
->
let
op
=
binop_of_tag
t
in
let
*
t1
=
type_expr_binop
op
t1
t2
in
OK
(
Ebinop
(
op
,
expr1
,
expr2
)
,
t1
)
|
Node
(
t
,
[
e1
])
when
tag_is_unop
t
->
make_eexpr_of_ast
e1
typ_var
typ_fun
>>=
fun
(
expr1
,
t1
)
->
|
Node
(
t
,
[
e1
])
when
tag_is_unop
t
->
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
>>=
fun
(
expr1
,
t1
)
->
let
op
=
unop_of_tag
t
in
let
*
t1
=
type_expr_unop
op
t1
in
OK
(
Eunop
(
op
,
expr1
)
,
t1
)
|
Node
(
t
,
[
e1
])
when
t
=
Tint
->
make_eexpr_of_ast
e1
typ_var
typ_fun
|
Node
(
t
,
[
e1
])
when
t
=
Tint
->
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
|
IntLeaf
(
num
)
->
OK
(
Eint
(
num
)
,
Tint
)
|
StringLeaf
(
str
)
->
let
returned_expression
=
Evar
(
str
)
in
let
*
t
=
type_expr
typ_var
typ_fun
returned_expression
in
let
*
t
=
type_expr
struct_table
typ_var
typ_fun
returned_expression
in
OK
(
returned_expression
,
t
)
|
CharLeaf
(
c
)
->
OK
(
Echar
(
c
)
,
Tchar
)
|
Node
(
Tp
,
[
e1
])
->
let
*
(
expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
in
let
*
(
expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
in
(
match
t
with
|
Tptr
t
->
OK
(
Eload
expr
,
t
)
|
_
->
Error
(
Printf
.
sprintf
"Can't Load non pointer here %s"
(
string_of_ast
a
)))
|
Node
(
Taddrof
,
[
e1
])
->
let
*
(
expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
in
let
*
(
expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
in
OK
(
Eaddrof
(
expr
)
,
Tptr
t
)
|
Node
(
Tstructunfoll
,
[
e1
;
StringLeaf
field
])
->
let
*
(
struct_expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
in
(
match
t
with
|
Tptr
Tstruct
s
->
let
*
t
=
field_type
struct_table
s
field
in
OK
(
Egetfield
(
struct_expr
,
field
)
,
t
)
|
_
->
Error
"Bad expression"
)
|
Node
(
Tstructpoint
,
[
e1
;
StringLeaf
field
])
->
(
let
*
(
struct_expr
,
t
)
=
make_eexpr_of_ast
e1
typ_var
typ_fun
struct_table
in
match
t
with
|
Tptr
Tstruct
name
->
let
*
t'
=
field_type
struct_table
name
field
in
OK
(
Eaddrof
(
Egetfield
(
struct_expr
,
field
))
,
Tptr
t'
)
|
Tstruct
name
->
let
*
t'
=
field_type
struct_table
name
field
in
OK
(
Eaddrof
(
Egetfield
((
Eaddrof
struct_expr
)
,
field
))
,
Tptr
t'
)
|
_
->
Error
"It should point to struct"
)
|
_
->
Error
(
Printf
.
sprintf
"Unacceptable ast in make_eexpr_of_ast %s"
(
string_of_ast
a
))
in
match
res
with
(
match
res
with
OK
o
->
res
|
Error
msg
->
Error
(
Format
.
sprintf
"In make_eexpr_of_ast %s:
\n
%s"
(
string_of_ast
a
)
msg
)
(
string_of_ast
a
)
msg
))
let
rec
make_einstr_of_ast
(
a
:
tree
)
typ_var
typ_fun
ret_typ
:
instr
res
=
let
rec
make_einstr_of_ast
(
a
:
tree
)
typ_var
typ_fun
struct_table
(
ret_typ
:
typ
)
:
instr
res
=
let
res
=
match
a
with
|
NullLeaf
->
OK
(
Iblock
[]
)
...
...
@@ -229,67 +274,86 @@ let rec make_einstr_of_ast (a: tree) typ_var typ_fun ret_typ: instr res =
|
Node
(
Targs
,
l
)
::
[]
->
l
|
_
->
[]
)
in
list_map_res
(
fun
e
->
make_eexpr_of_ast
e
typ_var
typ_fun
)
args_list
>>=
fun
args_expr
->
list_map_res
(
fun
e
->
make_eexpr_of_ast
e
typ_var
typ_fun
struct_table
)
args_list
>>=
fun
args_expr
->
let
(
args_expr
,
args_t
)
=
List
.
split
args_expr
in
let
returned_expression
=
Icall
(
name
,
args_expr
)
in
let
(
args_typ
,_
)
=
Hashtbl
.
find
typ_fun
name
in
if
(
List
.
length
args_typ
)
!=
(
List
.
length
args_t
)
then
Error
(
Format
.
sprintf
"%s called with %d instead of %d"
name
(
List
.
length
args_t
)
(
List
.
length
args_typ
)
)
else
let
does_args_typ_match
=
List
.
for_all2
(
=
)
args_typ
args_t
in
let
does_args_typ_match
=
List
.
for_all2
(
fun
t1
t2
->
match
are_types_compatible
t1
t2
with
|
OK
_
->
true
|
Error
_
->
false
)
args_typ
args_t
in
if
does_args_typ_match
then
let
*
t
=
type_expr
typ_var
typ_fun
(
Ecall
(
name
,
args_expr
))
in
let
*
t
=
type_expr
struct_table
typ_var
typ_fun
(
Ecall
(
name
,
args_expr
))
in
OK
(
returned_expression
)
else
Error
(
Format
.
sprintf
"arguments types does not match in expression calling %s"
name
)