diff --git a/ast.ml b/ast.ml index 6d7ef92..35bc716 100644 --- a/ast.ml +++ b/ast.ml @@ -5,17 +5,19 @@ type type_t = | Bool_t | Str_t | Func_t of type_t * type_t list + | Ptr_t of type_t + +type ident = string module Syntax = struct - type ident = string - type value = | Void | Int of int | Bool of bool | Str of string + | Ptr of expr - type expr = + and expr = | Val of { value : value ; pos : Lexing.position @@ -30,6 +32,10 @@ module Syntax = struct ; pos : Lexing.position } + type lval = + | Name of ident + | Addr of expr + type instr = | Decl of { name : ident @@ -37,7 +43,7 @@ module Syntax = struct ; pos : Lexing.position } | Assign of - { var : ident + { lval : lval ; expr : expr ; pos : Lexing.position } @@ -93,6 +99,7 @@ module V1 = struct | Int of int | Bool of bool | Str of string + | Ptr of int end module V2 = struct @@ -101,19 +108,22 @@ module V2 = struct | Int of int | Bool of bool | Data of string + | Ptr of int end module IR (P : Parameters) = struct - type ident = string - type expr = | Val of P.value | Var of ident | Call of ident * expr list + type lval = + | Name of ident + | Addr of expr + type instr = | Decl of ident - | Assign of ident * expr + | Assign of lval * expr | Do of expr | Cond of expr * block * block | Loop of expr * block diff --git a/baselib.ml b/baselib.ml index fa57cba..b78990c 100644 --- a/baselib.ml +++ b/baselib.ml @@ -16,6 +16,8 @@ let _types_ = ; "puti", Func_t (Void_t, [ Int_t ]) ; "puts", Func_t (Void_t, [ Str_t ]) ; "geti", Func_t (Int_t, []) + ; "alloc", Func_t (Ptr_t Magic_t, [ Int_t ]) + ; "%deref", Func_t (Magic_t, [ Ptr_t Magic_t ]) ]) ;; @@ -54,5 +56,7 @@ let builtins uniq = ; "puti", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.print_int); Syscall ] ; "puts", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.print_str); Syscall ] ; "geti", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.read_int); Syscall ] + ; "alloc", [ Lw (A0, Mem (SP, 0)); Li (V0, Syscall.sbrk); Syscall ] + ; "%deref", [ Lw (T0, Mem (SP, 0)); Lw (A0, Mem (T0, 0)); Syscall ] ] ;; diff --git a/compiler.ml b/compiler.ml index 99da664..37df521 100644 --- a/compiler.ml +++ b/compiler.ml @@ -19,6 +19,7 @@ let compile_value = function | Int n -> [ Li (V0, n) ] | Bool b -> [ Li (V0, if b then 1 else 0) ] | Data l -> [ La (V0, Lbl l) ] + | Ptr p -> [ Li (V0, p) ] ;; let rec compile_expr env = function @@ -47,9 +48,18 @@ let rec compile_expr env = function let rec compile_instr info = function | Decl v -> { info with env = Env.add v (Mem (FP, -info.fpo)) info.env; fpo = info.fpo + 4 } - | Assign (v, e) -> + | Assign (lv, e) -> { info with - asm = info.asm @ compile_expr info.env e @ [ Sw (V0, Env.find v info.env) ] + asm = + (info.asm + @ compile_expr info.env e + @ + match lv with + | Name v -> [ Sw (V0, Env.find v info.env) ] + | Addr e -> + [ Addi (SP, SP, -4); Sw (V0, Mem (SP, 0)) ] + @ compile_expr info.env e + @ [ Lw (T0, Mem (SP, 0)); Addi (SP, SP, 4); Sw (T0, Mem (V0, 0)) ]) } | Cond (e, ib, eb) -> let uniq = string_of_int info.cnt in diff --git a/errors.ml b/errors.ml index 3d0d63a..6625f61 100644 --- a/errors.ml +++ b/errors.ml @@ -26,6 +26,7 @@ let rec string_of_type_t = function ^ (if List.length a > 1 then ")" else "") ^ " -> " ^ string_of_type_t r + | Ptr_t t -> "*" ^ string_of_type_t t ;; let errt expected given pos = diff --git a/lexer.mll b/lexer.mll index f2588bf..c22364a 100644 --- a/lexer.mll +++ b/lexer.mll @@ -32,7 +32,7 @@ rule token = parse | ';' { Lsc } | '+' { Ladd } | '-' { Lsub } - | '*' { Lmul } + | '*' { Lstar } | '/' { Ldiv } | '<' { Lsmaller } | '>' { Lbigger } diff --git a/main.ml b/main.ml index a6ade27..fcdb049 100644 --- a/main.ml +++ b/main.ml @@ -10,7 +10,7 @@ let () = try let parsed = Parser.prog Lexer.token buf in close_in f; - (* Test.debug_parser Stdlib.stderr parsed; *) + Test.debug_parser Stdlib.stderr parsed; let ast = Semantics.analyze parsed in (* Test.debug_semantics Stdlib.stderr ast; *) let asm = Compiler.compile (Simplifier.simplify ast) in diff --git a/parser.mly b/parser.mly index df5c3db..a3779f4 100644 --- a/parser.mly +++ b/parser.mly @@ -11,10 +11,10 @@ %token Lend Lassign Lsc Lreturn %token Lbracedeb Lbracefin %token Lpardeb Lparfin Lcomma -%token Ladd Lsub Lmul Ldiv Lbigger Lsmaller Leq Lneq +%token Ladd Lsub Lstar Ldiv Lbigger Lsmaller Leq Lneq %token Lif Lelse Lwhile -%left Ladd Lsub Lmul Ldiv Lbigger Lsmaller Leq Lneq +%left Ladd Lsub Lstar Ldiv Lbigger Lsmaller Leq Lneq %left Lbracedeb Lparfin Lbracefin Lreturn %left Ltype Lbool Lint Lvar Lstr @@ -94,20 +94,37 @@ instr: ; pos = $startpos } ] } + /* type *v; */ + | t = Ltype ; Lstar ; v = Lvar ; Lsc { + [ Decl { name = v ; type_t = Ptr_t t ; pos = $startpos(t) } ] + } + /* type v; */ | t = Ltype ; v = Lvar ; Lsc { [ Decl { name = v ; type_t = t ; pos = $startpos(t) } ] } + /* type *v = e; */ + | t = Ltype ; Lstar ; v = Lvar ; Lassign ; e = expr ; Lsc + { [ Decl { name = v ; type_t = Ptr_t t ; pos = $startpos(t) } + ; Assign { lval = Name v ; expr = e ; pos = $startpos(v) } ] + } /* type v = e; */ | t = Ltype ; v = Lvar ; Lassign ; e = expr ; Lsc { [ Decl { name = v ; type_t = t ; pos = $startpos(t) } - ; Assign { var = v ; expr = e ; pos = $startpos(v) } ] + ; Assign { lval = Name v ; expr = e ; pos = $startpos(v) } ] } + /* *v = e; */ + | Lstar; v = Lvar ; Lassign ; e = expr ; Lsc { + [ Assign { lval = Addr (Var { name = v ; pos = $startpos(v) }) + ; expr = e + ; pos = $startpos(e) } ] + } + /* v = e; */ | v = Lvar ; Lassign ; e = expr ; Lsc { - [ Assign { var = v ; expr = e ; pos = $startpos($2) } ] + [ Assign { lval = Name v ; expr = e ; pos = $startpos($2) } ] } /* e; */ @@ -162,7 +179,7 @@ expr: } /* e * e */ - | a = expr ; Lmul ; b = expr { + | a = expr ; Lstar ; b = expr { Call { func = "%mul" ; args = [ a ; b ] ; pos = $startpos($2) } } @@ -191,6 +208,11 @@ expr: Call { func = "%neq" ; args = [ a ; b ] ; pos = $startpos($2) } } + /* *e */ + | Lstar; a = expr { + Call { func = "%deref" ; args = [ a ] ; pos = $startpos } + } + /* function(a */ | f = Lvar ; Lpardeb ; a = args_expr { Call { func = f ; args = a ; pos = $startpos(a) } diff --git a/semantics.ml b/semantics.ml index 45ad794..9a15da7 100644 --- a/semantics.ml +++ b/semantics.ml @@ -4,31 +4,38 @@ open Ast.V1 open Baselib open Errors -let analyze_value = function +let rec analyze_value = function | Syntax.Void -> Void, Void_t | Syntax.Int n -> Int n, Int_t | Syntax.Bool b -> Bool b, Bool_t | Syntax.Str s -> Str s, Str_t + | Syntax.Ptr v -> + let v2, t = analyze_value v in + Ptr 0, Ptr_t t ;; let rec analyze_expr env ua t = function | Syntax.Val v -> let v2, new_t = analyze_value v.value in - if new_t != t && t != Magic_t then errt t new_t v.pos; + (match t with + | Ptr_t t2 -> if new_t != t && t2 != Magic_t then errt t new_t v.pos + | _ -> if new_t != t && t != Magic_t then errt t new_t v.pos); Val v2, new_t | Syntax.Var v -> if not (Env.mem v.name env) then raise (SemanticsError ("Unbound variable \"" ^ v.name ^ "\"", v.pos)); if List.mem v.name ua then warn ("Unassigned variable \"" ^ v.name ^ "\"") v.pos; let new_t = Env.find v.name env in - if new_t != t then errt t new_t v.pos; + if new_t != t && t != Magic_t then errt t new_t v.pos; Var v.name, new_t | Syntax.Call c -> if not (Env.mem c.func env) then raise (SemanticsError ("Unbound function \"" ^ c.func ^ "\"", c.pos)); (match Env.find c.func env with | Func_t (ret_t, tl) -> - if ret_t != t && t != Magic_t then errt ret_t t c.pos; + (match ret_t with + | Ptr_t t2 -> if ret_t != t && t2 != Magic_t then errt ret_t t c.pos + | _ -> if ret_t != t && t != Magic_t then errt ret_t t c.pos); if List.length tl != List.length c.args then raise @@ -63,10 +70,23 @@ let rec analyze_expr env ua t = function let rec analyze_instr env ua ret_t = function | Syntax.Decl d -> Decl d.name, Env.add d.name d.type_t env, [ d.name ] @ ua | Syntax.Assign a -> - if not (Env.mem a.var env) - then raise (SemanticsError ("Unbound variable \"" ^ a.var ^ "\"", a.pos)); - let ae, et = analyze_expr env ua (Env.find a.var env) a.expr in - Assign (a.var, ae), env, List.filter (fun x -> x <> a.var) ua + let var, t = + match a.lval with + | Name i -> i, Env.find i env + | Addr e -> + let ae, t = analyze_expr env ua Magic_t e in + (match ae with + | Var v -> + ( v + , (match t with + | Ptr_t t -> t + | _ -> raise (SemanticsError ("Something went wrong", a.pos))) ) + | _ -> raise (SemanticsError ("Can't assign to this address", a.pos))) + in + if not (Env.mem var env) + then raise (SemanticsError ("Unbound variable \"" ^ var ^ "\"", a.pos)); + let ae, et = analyze_expr env ua t a.expr in + Assign (Name var, ae), env, List.filter (fun x -> x <> var) ua | Syntax.Do d -> let ae, _ = analyze_expr env ua Magic_t d.expr in Do ae, env, [] diff --git a/simplifier.ml b/simplifier.ml index 532cb91..025f946 100644 --- a/simplifier.ml +++ b/simplifier.ml @@ -4,7 +4,7 @@ open Baselib let collect_constant_strings code = let counter = ref (-1) in let env = ref Env.empty in - let ccs_value = function + let rec ccs_value = function | V1.Void -> V2.Void, [] | V1.Bool b -> V2.Bool b, [] | V1.Int n -> V2.Int n, [] @@ -16,6 +16,9 @@ let collect_constant_strings code = let lbl = "str" ^ string_of_int !counter in env := Env.add s lbl !env; V2.Data lbl, [ lbl, Mips.Asciiz s ]) + | V1.Ptr p -> + let v2, ccs = ccs_value p in + V2.Ptr v2, [] @ ccs in let rec ccs_expr = function | IR1.Val v -> @@ -26,11 +29,18 @@ let collect_constant_strings code = let args2 = List.map ccs_expr args in IR2.Call (fn, List.map fst args2), List.flatten (List.map snd args2) in + let ccs_lval = function + | IR1.Name v -> IR2.Name v, [] + | IR1.Addr e -> + let e2, ccs = ccs_expr e in + IR2.Addr e2, ccs + in let rec ccs_instr = function | IR1.Decl v -> IR2.Decl v, [] | IR1.Assign (lv, e) -> + let lv2, ccs2 = ccs_lval lv in let e2, ccs = ccs_expr e in - IR2.Assign (lv, e2), ccs + IR2.Assign (lv2, e2), ccs @ ccs2 | IR1.Do e -> let e2, ccs = ccs_expr e in IR2.Do e2, ccs diff --git a/test.ml b/test.ml index 79f160c..1f6e8b6 100644 --- a/test.ml +++ b/test.ml @@ -9,14 +9,18 @@ let debug_parser oc parsed = | Syntax.Int d -> "Int " ^ string_of_int d | Syntax.Bool d -> "Bool " ^ string_of_bool d | Syntax.Str s -> "Str \"" ^ s ^ "\"" + | Syntax.Ptr t -> "*" ^ fmt_v t and fmt_e = function | Syntax.Val d -> "Val (" ^ fmt_v d.value ^ ")" | Syntax.Var d -> "Var \"" ^ d.name ^ "\"" | Syntax.Call d -> "Call (\"" ^ d.func ^ "\", [ " ^ String.concat " ; " (List.map fmt_e d.args) ^ " ])" + and fmt_lv = function + | Syntax.Name n -> "Name(\"" ^ n ^ "\")" + | Syntax.Addr e -> "Addr(" ^ fmt_e e ^ ")" and fmt_i = function | Syntax.Decl d -> "Decl(" ^ string_of_type_t d.type_t ^ ") \"" ^ d.name ^ "\"" - | Syntax.Assign d -> "Assign (\"" ^ d.var ^ "\", " ^ fmt_e d.expr ^ ")" + | Syntax.Assign d -> "Assign (" ^ fmt_lv d.lval ^ ", " ^ fmt_e d.expr ^ ")" | Syntax.Do d -> "Do (" ^ fmt_e d.expr ^ ")" | Syntax.Cond c -> "Cond (" ^ fmt_e c.expr ^ ", " ^ fmt_b c.if_b ^ ", " ^ fmt_b c.else_b ^ ")" @@ -50,6 +54,7 @@ let debug_semantics oc ast = | Int n -> "Int " ^ string_of_int n | Bool b -> "Bool " ^ string_of_bool b | Str s -> "Str \"" ^ s ^ "\"" + | Ptr p -> "Ptr of " ^ fmt_v p and fmt_e = function | Val v -> "Val (" ^ fmt_v v ^ ")" | Var v -> "Var \"" ^ v ^ "\"" @@ -57,7 +62,14 @@ let debug_semantics oc ast = "Call (\"" ^ f ^ "\", [ " ^ String.concat " ; " (List.map fmt_e a) ^ " ])" and fmt_i = function | Decl v -> "Decl \"" ^ v ^ "\"" - | Assign (v, e) -> "Assign (\"" ^ v ^ "\", " ^ fmt_e e ^ ")" + | Assign (lv, e) -> + "Assign (\"" + ^ (match lv with + | Name v -> v + | Addr e -> fmt_e e) + ^ "\", " + ^ fmt_e e + ^ ")" | Do e -> "Do (" ^ fmt_e e ^ ")" | Cond (c, i, e) -> "Cond (" ^ fmt_e c ^ ", " ^ fmt_b i ^ ", " ^ fmt_b e ^ ")" | Loop (c, b) -> "Loop (" ^ fmt_e c ^ ", " ^ fmt_b b ^ ")" diff --git a/tests/34_alloc.test b/tests/34_alloc.test new file mode 100644 index 0000000..d16ef5d --- /dev/null +++ b/tests/34_alloc.test @@ -0,0 +1,7 @@ +void main () { + int *a = alloc(8); + *a = 4; + puti(a); + puts(" - "); + puti(*a); +}