module List = ListLabels
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
| 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
let check_int expty ~pos : unit =
check_same return_int expty ~pos
+ let paths_of_typedecs typedecs : (Sym.t * Sym.t * Pos.t) list list =
+ let (path, paths) =
+ List.fold_left typedecs ~init:([], []) ~f:(
+ fun (path, paths) (A.TypeDec {name=child; ty; pos}) ->
+ match ty with
+ | A.NameTy {symbol=parent; _} ->
+ (((parent, child, pos) :: path), paths)
+ | A.RecordTy _
+ | A.ArrayTy _ ->
+ ([], path :: paths)
+ )
+ in
+ List.map (path :: paths) ~f:List.rev
+
+ let check_cycles (typedecs : A.typedec list) : unit =
+ let non_empty_paths =
+ List.filter
+ (paths_of_typedecs typedecs)
+ ~f:(function [] -> false | _ -> true)
+ in
+ List.iter non_empty_paths ~f:(
+ fun path ->
+ match Dag.of_list (List.map path ~f:(fun (p, c, _) -> (p, c))) with
+ | Ok _ ->
+ ()
+ | Error `Cycle ->
+ let (_, from_id, from_pos) = List.hd path in
+ let (_, to_id, to_pos) = List.hd (List.rev path) in
+ E.raise (E.Cycle_in_type_decs {from_id; from_pos; to_id; to_pos})
+ )
+
let rec transExp ~env exp =
let rec trexp exp =
(match exp with
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
| 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 *)
(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
| 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
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 =
List.fold_left typedecs ~init:env ~f:(
fun env (A.TypeDec {name; ty=_; pos=_}) ->
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
| 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:(
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 *)
);
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
(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
()
home / code / tiger.ml.git / blobdiff