Rough frame allocations

[tiger.ml.git] / compiler / src / lib / tiger / tiger_semant.ml

diff --git a/compiler/src/lib/tiger/tiger_semant.ml b/compiler/src/lib/tiger/tiger_semant.ml
index 6bb45fd..f809509 100644 (file)
--- 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
@@ -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
@@ -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
   ()