X-Git-Url: https://git.xandkar.net/?a=blobdiff_plain;f=compiler%2Fsrc%2Flib%2Ftiger%2Ftiger_semant.ml;h=ad46207837301617e41187a305588b4f34ec1bbc;hb=refs%2Fheads%2Fir-translation-wip;hp=6bb45fd515a5fb3fe1788417118c5b4b2c144b5a;hpb=e6e82c0866db4eb08f956b2582e5c2ed5399e986;p=tiger.ml.git diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml index 6bb45fd..ad46207 100644 --- a/compiler/src/lib/tiger/tiger_semant.ml +++ b/compiler/src/lib/tiger/tiger_semant.ml @@ -4,8 +4,10 @@ module A = Tiger_absyn module Dag = Tiger_dag module Env = Tiger_env module E = Tiger_error +module Escape = Tiger_semant_escape module Pos = Tiger_position module Sym = Tiger_symbol +module Temp = Tiger_temp module Translate = Tiger_translate module Type = Tiger_env_type module Value = Tiger_env_value @@ -52,7 +54,7 @@ end = struct | Type.Array _ -> ty - let return ty = {exp = (); ty} + let return ty = {exp = Translate.dummy__FIXME; ty} let return_unit = return Type.Unit let return_nil = return Type.Nil let return_int = return Type.Int @@ -122,7 +124,7 @@ end = struct return_string | A.CallExp {func; args; pos} -> (match env_get_val ~sym:func ~env ~pos with - | Value.Fun {formals; result} -> + | Value.Fun {formals; result; level=_; label=_} -> let expected = List.length formals in let given = List.length args in if given = expected then @@ -192,16 +194,28 @@ end = struct | A.WhileExp {test; body; pos} -> (* test : must be int, because we have no bool *) check_int (trexp test) ~pos; - ignore (trexp body); (* Only care if a type-error is raised *) + let (loop, env) = Env.loop_begin env in + (* Only care if an error is raised *) + ignore (transExp ~env body); + ignore (Env.loop_end env loop); return_unit | A.ForExp {var; lo; hi; body; pos; escape=_} -> check_int (trexp lo) ~pos; check_int (trexp hi) ~pos; - (* Only care if a type-error is raised *) - let env = Env.set_val env var (Value.Var {ty = Type.Int}) in + let (loop, env) = Env.loop_begin env in + let level = Env.level_get env in + (* Assuming all escape, for now *) + let access = Translate.alloc_local ~level ~escapes:true in + let env = Env.set_val env var (Value.Var {ty = Type.Int; access}) in + (* Only care if an error is raised *) ignore (transExp ~env body); + ignore (Env.loop_end env loop); return_unit - | A.BreakExp _ -> + | A.BreakExp pos -> + (match Env.loop_current env with + | Some _ -> () + | None -> E.raise (E.Break_outside_loop pos) + ); return_unit | A.LetExp {decs; body; pos=_} -> (* (1) decs augment env *) @@ -229,8 +243,10 @@ end = struct (function | A.SimpleVar {symbol=sym; pos} -> (match env_get_val ~sym ~env ~pos with - | Value.Fun _ -> E.raise (E.Id_is_a_function {id=sym; pos}) - | Value.Var {ty} -> return (actual_ty ~pos ty) + | Value.Fun _ -> + E.raise (E.Id_is_a_function {id=sym; pos}) + | Value.Var {ty; access=_} -> + return (actual_ty ~pos ty) ) | A.FieldVar {var; symbol; pos} -> let {exp=_; ty} = trvar var in @@ -309,7 +325,7 @@ end = struct | A.VarDec {name; typ=typ_opt; init; pos=pos_outter; escape=_} -> let ty = (match (typ_opt, transExp ~env init) with - | None, {ty; exp=()} -> + | None, {ty; exp=_} -> ty | Some (sym, pos_inner), expty_init -> let ty = env_get_typ_actual ~sym ~env ~pos:pos_inner in @@ -317,7 +333,12 @@ end = struct ty ) in - Env.set_val env name (Value.Var {ty}) + let access = + Translate.alloc_local + ~level:(Env.level_get env) + ~escapes:true (* Assuming all escape, for now... *) + in + Env.set_val env name (Value.Var {ty; access}) | A.TypeDecs typedecs -> check_cycles typedecs; let env = @@ -326,9 +347,9 @@ end = struct Env.set_typ env name (Type.Name (name, ref None)) ) in - List.iter typedecs ~f:(fun (A.TypeDec {name; ty=ty_exp; pos}) -> - let ty = transTy ~env ty_exp in - (match env_get_typ ~sym:name ~env ~pos with + List.iter typedecs ~f:(fun (A.TypeDec {name=ty_name; ty=ty_exp; pos}) -> + let ty = transTy ~env ~ty_name ~ty_exp in + (match env_get_typ ~sym:ty_name ~env ~pos with | Type.Name (_, ty_opt_ref) -> ty_opt_ref := Some ty | Type.Unit @@ -356,7 +377,16 @@ end = struct | Some (s, p) -> env_get_typ_actual ~sym:s ~env ~pos:p | None -> Type.Unit in - Env.set_val env name (Value.Fun {formals; result}) + let label = Temp.Label.gen () in + let level = + Translate.Level.next + (Env.level_get env) + ~name:label + (* Assuming all escape (for now) *) + ~formals:(List.map formals ~f:(fun _ -> true)) + in + let env = Env.level_set env level in + Env.set_val env name (Value.Fun {formals; result; level; label}) ) in List.iter fundecs ~f:( @@ -365,7 +395,13 @@ end = struct List.fold_left params ~init:env_with_fun_heads_only ~f:( fun env (A.Field {name=var_name; escape=_; typ; pos}) -> let var_ty = env_get_typ_actual ~env ~sym:typ ~pos in - Env.set_val env var_name (Value.Var {ty = var_ty}) + let level = Env.level_get env in + (* Assuming all escape, for now *) + let access = Translate.alloc_local ~level ~escapes:true in + Env.set_val + env + var_name + (Value.Var {ty = var_ty; access}) ) in (* we only care if an exception is raised *) @@ -373,7 +409,7 @@ end = struct ); env_with_fun_heads_only ) - and transTy ~(env : Env.t) (ty_exp : A.ty) : Type.t = + and transTy ~(env : Env.t) ~ty_name ~(ty_exp : A.ty) : Type.t = (match ty_exp with | A.NameTy {symbol=sym; pos} -> env_get_typ ~sym ~env ~pos @@ -384,15 +420,16 @@ end = struct (name, ty) ) in - Type.new_record fields + Type.new_record ~name:ty_name ~fields | A.ArrayTy {symbol=sym; pos} -> let element_ty = env_get_typ ~sym ~env ~pos in - Type.new_array element_ty + Type.new_array ~name:ty_name ~ty:element_ty ) end open Semant let transProg absyn = + Escape.find ~prog:absyn; let {exp = _; ty = _} = transExp absyn ~env:Env.base in ()