Commits

hogekura committed e96897a

Comments (0)

Files changed (10)

           | CallExp of symbol * exp list * Loc.t
           | OpExp of exp * oper * exp * Loc.t
           | RecordExp of (symbol * exp * Loc.t) list * symbol * Loc.t
-          | SeqExp of (exp * Loc.t) list * Loc.t
+          | SeqExp of exp list * Loc.t
           | AssignExp of var * exp * Loc.t
           | IfExp of exp * exp * exp option * Loc.t
           | WhileExp of exp * exp * Loc.t
         | TypeDec of (symbol * ty * Loc.t) list
 
 and ty = NameTy of symbol * Loc.t
-       | RecordTy of field list
+       | RecordTy of field list * Loc.t
        | ArrayTy of symbol * Loc.t
 
 and oper = PlusOp | MinusOp | TimesOp | DivideOp
   | LetExp (_, _, loc)
   | ArrayExp (_, _, _, loc) -> loc
 ;;
+
+let loc_of_typ = function
+  | NameTy (_, loc) -> loc
+  | RecordTy (_, loc) -> loc
+  | ArrayTy (_, loc) -> loc
 	  | ( '`':: _ :: rest) -> Errormsg.impossible "bad Assem format"
 	  | (c :: rest) -> (c :: f rest)
 	  | [] -> [] in
-    
+
     implode( f (explode assem)) in
-  
+
   function
   | OPER {op_assem; op_dst; op_src; jump=None} -> speak op_assem op_dst op_src []
   | OPER {op_assem; op_dst; op_src; jump=Some j} -> speak op_assem op_dst op_src j
   | LABEL {lb_assem} -> lb_assem
-  | MOVE {mv_assem; mv_dst; mv_src} -> speak mv_assem [mv_dst] [mv_src] [] 
+  | MOVE {mv_assem; mv_dst; mv_src} -> speak mv_assem [mv_dst] [mv_src] []
 ;;
 
 
 let argregs = [rdi; rsi; rdx; rcx; r8; r9] ;;
 let calleesaves = [rbx; r10; r13; r14; r15] ;;
 let callersaves = [r11; r12] ;;
-
   MenhirLib.Convert.Simplified.traditional2revised Parser.program tiger_lexer;;
 
 let parse_error lexbuf =
-  let pos = L.get_pos lexbuf in
-  Errormsg.error pos "error" ;;
+  let (start, end_) = L.loc lexbuf in
+  Errormsg.error {Loc.start; Loc.end_} "error" ;;
 
 let parse filename =
   let in_ = open_in filename in
     tee (parse filename) ~f:(debug ~message:"parse" Show.show<Absyn.exp>) |> Semant.trans_prog in
   debug ~message:"trans exp" Show.show<Tree.exp> (Tr.unEx exp.Semant.exp);
   debug ~message:"type" Show.show<Tiger_types.ty> (exp.Semant.ty);
-  
+
   let canon stm =
     Canon.linearize stm
   |> tee ~f:(debug ~message:"linearize" Show.show<Tree.stm list>)
   |> tee ~f:(fun x -> fst x |> List.iter ~f:(debug ~message:"basic_block" Show.show<Tree.stm list>))
   |> uncurry Canon.trace_schedule
   |> tee ~f:(debug ~message:"trace_schedule" Show.show<Tree.stm list>) in
-  canon (exp.Semant.exp |> Tr.unNx) |> ignore;
 
   List.iter (fun p ->
     tee p ~f:(debug ~message:"proc" Show.show<Tr.frag>) |> function
     | Translate.PROC (stm, frame) ->
       List.map (canon stm) ~f:(Codegen.codegen frame)
     |> List.iter ~f:(
-      debug ~message:"-----------------------------------------" (Show.show <Assem.instr list>))
+      debug ~message:"-----------------------------------------"
+        (Show.show <Assem.instr list>))
     | _ -> ()) flags;
+
+  List.map (canon (Tr.unNx exp.Semant.exp)) ~f:(Codegen.codegen Tr.outermost.Tr.frame)
+  |> debug ~message:"main"
+      (fun ss -> Show.show <Assem.instr list> @@ List.concat ss)
 ;;
 
 let rec ns n m =
 
 exception Error ;;
 
-let error pos msg =
-  let rec look ls n = match ls with
+let error loc msg =
+  let rec look pos ls n = match ls with
     | a :: rest ->
       if a < pos then
         (n, (pos - a))
       else
-        look rest (n - 1)
+        look pos rest (n - 1)
     | _ -> (0, 0) in
   any_errors := true;
-  let (line, pos) = look !line_pos !line_num in
+  let (line, pos) = look loc.Loc.start !line_pos !line_num in
   ep "%s:%d.%d:%s\n" !file_name line pos msg;
   flush stderr
 ;;
 val line_num : int ref
 val line_pos : int list ref
 val source_stream : in_channel ref
-val error : int -> string -> unit
+val error : Loc.t -> string -> unit
 exception Error
 val impossible : string -> 'a   (* raises Error *)
 val reset : unit -> unit

src/find_escape.ml

 let rec traverse_var env d = function
   | SimpleVar (v, loc) ->
     begin match S.look env v with
-    | None -> sp "%s not found" (S.name v) |> E.error loc.Loc.start
+    | None -> sp "%s not found" (S.name v) |> E.error loc
     | Some (depth, escape) ->
       if d < depth then escape := true
     end
     | CallExp (_, es, loc) -> List.iter es ~f:(fun e -> tr_exp e)
     | OpExp (e1, _, e2, _) -> tr_exp e1; tr_exp e2;
     | RecordExp (rec_decs, s, _) -> List.iter rec_decs ~f:(fun (_, e, _) -> tr_exp e)
-    | SeqExp (sec, _) -> List.iter sec ~f:(fun (e, _) -> tr_exp e)
+    | SeqExp (sec, _) -> List.iter sec ~f:(fun e -> tr_exp e)
     | AssignExp (v, e, _) -> traverse_var env d v; tr_exp e;
     | IfExp (e1, e2, e3, _) -> begin
       tr_exp e1;
   | [' ' '\t']+ -> to_token lexbuf
   | "/*" -> in_comment lexbuf
   | _ -> begin
-    E.error (L.get_pos lexbuf) ("illegal character");
+    let pos = L.get_pos lexbuf in
+    E.error ({start = pos; end_ = pos + 1}) ("illegal character");
     to_token lexbuf
   end
 
 
 exp_field:
  | id = ID EQ exp = expr
-   {let loc = $2 in
-    let (_, name) = id in
-    (S.symbol name, exp, loc)}
+   {let ({start}, name) = id in
+    let {end_} = loc_of_exp exp in
+    (S.symbol name, exp, {start; end_})}
 
 exp_fields_:
  | exp_field {[$1]}
  | exp_fields_ { $1 }
 
 lvalue:
- | var = ID {let (loc, name) = var in (SimpleVar (S.symbol name, loc))}
+ | var = ID
+   {let (loc, name) = var in (SimpleVar (S.symbol name, loc))}
  | e = lvalue DOT id = ID
-   {let {start} = $2 in
+   {let {start} = loc_of_var e in
     let {end_}, id = id in
     FieldVar (e, S.symbol id, {start; end_}) }
  | e = lvalue LBRACK idx = expr RBRACK
-   {let {start} = $2 in
-    let {end_} = $4 in
+   {let {start} = loc_of_var e in
+    let {end_}  = $4  in
     SubscriptVar (e, idx, {start; end_}) }
 
 simple_expr:
  | NIL {let loc = $1 in NilExp loc}
  | INT {let (loc, i) = $1 in IntExp (i, loc)}
  | STRING {let (loc, str) = $1 in StringExp (str, loc)}
- | LET ds = decs IN e = semi_exprs END
+ | LET ds = decs IN es = semi_exprs END
    {let {start} = $1 in
     let {end_} = $5 in
-    LetExp (ds, SeqExp (loc_es e $3, $3), {start; end_})}
- | var = ID {let (loc, name) = var in VarExp (SimpleVar (S.symbol name, loc))}
+    LetExp (ds, SeqExp (es, $3), {start; end_})}
+ | var = ID
+   {let (loc, name) = var in VarExp (SimpleVar (S.symbol name, loc))}
  | ty_id = ID LBRACE es = exp_fields RBRACE
    { let ({start}, id) = ty_id in
      let {end_} = $4 in
      RecordExp (es, S.symbol id, {start; end_}) }
- | LPAREN semi_exprs RPAREN
-   {let es = loc_es $2 $3 in
-    let {start} = $1 in
+ | LPAREN es = semi_exprs RPAREN
+   {let {start} = $1 in
     let {end_} = $3 in
     SeqExp (es, {start; end_})}
 
 semi_exprs_:
- | expr SEMICOLON semi_exprs_ { let loc = $2 in (Some loc, $1) :: $3 }
- | expr { [(None, $1)] }
+ | e = expr SEMICOLON es = semi_exprs_
+   { e :: es }
+ | e = expr
+   { [e] }
 semi_exprs:
  | { [] }
  | semi_exprs_ { $1 }
 expr:
  | simple_expr {$1}
  | e = lvalue DOT id = ID
-   {let {start} = $2 in
+   {let {start} = loc_of_var e in
     let {end_}, id = id in
     VarExp (FieldVar (e, S.symbol id, {start; end_})) }
  | e = lvalue LBRACK idx = expr RBRACK
-   {let {start} = $2 in
+   {let {start} = loc_of_var e in
     let {end_} = $4 in
     VarExp (SubscriptVar (e, idx, {start; end_})) }
  | fun_id = ID LPAREN args = arg_list RPAREN
      CallExp (S.symbol id, args, {start; end_}) }
  | ty_id = lvalue LBRACK e1 = expr RBRACK OF e2 = expr
    { let ({start}, ty_id) = check_id ty_id in
-     let ({end_}) = $5 in
+     let ({end_}) = loc_of_exp e2 in
      ArrayExp (ty_id, e1, e2, {start; end_}) }
  | v = lvalue ASSIGN e = expr
-   { let loc = $2 in
-     AssignExp (v, e, loc) }
+   { let {start} = loc_of_var v in
+     let {end_} = loc_of_exp e in
+     AssignExp (v, e, {start; end_}) }
  | if_ = IF cond = expr THEN then_ = expr el = ELSE else_ = expr
    { let {start} = if_ in
-     let {end_} = el in
+     let {end_} = loc_of_exp else_ in
      IfExp (cond, then_, Some else_, {start; end_}) }
  | if_ = IF cond = expr th = THEN then_ = expr
    { let {start} = if_ in
-     let {end_} = th in
+     let {end_} = loc_of_exp then_ in
      IfExp (cond, then_, None, {start; end_}) }
  | BREAK {BreakExp $1}
  | w = WHILE cond = expr d = DO e = expr
    { let {start} = w in
-     let {end_} = d in
+     let {end_} = loc_of_exp e in
      WhileExp (cond, e, {start; end_}) }
  | f = FOR id = ID ASSIGN e1 = expr TO e2 = expr d = DO e3 = expr
    { let {start} = f in
      let (id_loc, id) = id in
-     let {end_} = d in
+     let {end_} = loc_of_exp e3 in
      ForExp (S.symbol id, ref false, e1, e2, e3, {start; end_}) }
  | MINUS e = simple_expr
-   {let loc = $1 in OpExp (IntExp (0, loc), MinusOp, e, loc)}
+   {let {start} as loc = $1 in
+    let {end_}  = loc_of_exp e in
+    OpExp (IntExp (0, loc), MinusOp, e, {start; end_})}
  | e1 = expr PLUS e2 = expr
-   { let loc = $2 in OpExp (e1, PlusOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, PlusOp, e2, {start; end_}) }
  | e1 = expr MINUS e2 = expr
-   { let loc = $2 in OpExp (e1, MinusOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, MinusOp, e2, {start; end_}) }
  | e1 = expr TIMES e2 = expr
-   { let loc = $2 in OpExp (e1, TimesOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, TimesOp, e2, {start; end_}) }
  | e1 = expr DIVIDE e2 = expr
-   { let loc = $2 in OpExp (e1, DivideOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, DivideOp, e2, {start; end_}) }
  | e1 = expr AND e2 = expr
-   { let loc = $2 in IfExp (e1, e2, Some (IntExp (0, loc)), loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     IfExp (e1, e2, Some (IntExp (0, $2)), {start; end_}) }
  | e1 = expr OR e2 = expr
-   { let loc = $2 in IfExp (e1, IntExp (1, loc), Some e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     IfExp (e1, IntExp (1, $2), Some e2, {start; end_}) }
  | e1 = expr EQ e2 = expr
-   { let loc = $2 in OpExp (e1, EqOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, EqOp, e2, {start; end_}) }
  | e1 = expr NEQ e2 = expr
-   { let loc = $2 in OpExp (e1, NeqOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, NeqOp, e2, {start; end_}) }
  | e1 = expr LT e2 = expr
-   { let loc = $2 in OpExp (e1, LtOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, LtOp, e2, {start; end_}) }
  | e1 = expr GT e2 = expr
-   { let loc = $2 in OpExp (e1, GtOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, GtOp, e2, {start; end_}) }
  | e1 = expr LE e2 = expr
-   { let loc = $2 in OpExp (e1, LeOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, LeOp, e2, {start; end_}) }
  | e1 = expr GE e2 = expr
-   { let loc = $2 in OpExp (e1, GeOp, e2, loc) }
+   { let {start} = loc_of_exp e1 in
+     let {end_}  = loc_of_exp e2 in
+     OpExp (e1, GeOp, e2, {start; end_}) }
 
 decs:
  | d = dec  { [d] }
  | d = dec ds = decs {d :: ds}
 
 typ:
+ | LPAREN ty = typ RPAREN {ty}
  | ID {let (loc, id) = $1 in NameTy (S.symbol id, loc)}
- | LBRACE ty_fields RBRACE {RecordTy $2}
+ | LBRACE ty_fields RBRACE {
+   let {start} = $1 in
+   let {end_}  = $3 in
+   RecordTy ($2, {start; end_})}
  | ARRAY OF ty_id = ID
    {let {start} = $1 in
     let ({end_}, id) = ty_id in
 tydec_one:
  | TYPE ty = ID EQ typ = typ
    {let {start} = $1 in
-    let {end_} = $3 in
+    let {end_} = loc_of_typ typ in
     let (loc, id) = ty in
     (S.symbol id, typ, {start; end_})}
 
  | FUNCTION fun_name = ID LPAREN params = ty_fields RPAREN EQ body = expr
    { let (_, fun_name) = fun_name in
      let {start} = $1 in
-     let {end_} = $6 in
+     let {end_} = loc_of_exp body in
      {fun_name = S.symbol fun_name; params; result_ty = None;
       body; fd_pos = {start; end_}}}
  | FUNCTION fun_name = ID LPAREN params = ty_fields RPAREN
    { let (_, fun_name) = fun_name in
      let (loc, result_ty) = res_ty_id in
      let {start} = $1 in
-     let {end_} = $8 in
+     let {end_} = loc_of_exp body in
      {fun_name = S.symbol fun_name; params; result_ty = Some (S.symbol result_ty, loc);
       body; fd_pos = {start; end_}}}
 
 vardec:
  | VAR v = ID ASSIGN e = expr
    {let {start} = $1 in
-    let {end_} = $3 in
+    let {end_} = loc_of_exp e in
     let (_, id) = v in
     VarDec (S.symbol id, ref false, None, e, {start; end_})}
  | VAR v = ID COLON ty = ID ASSIGN e = expr
    {let {start} = $1 in
-    let {end_} = $5 in
+    let {end_} = loc_of_exp e in
     let (_, v_id) = v in
     let (ty_loc, ty_id) = ty in
     VarDec (S.symbol v_id, ref false, Some (S.symbol ty_id, ty_loc),
 exception TypeError ;;
 
 let type_error loc expect fact =
-  E.error loc.Loc.start
+  E.error loc
     (sp "This expression has type %s, but an expression was expected of \\
 type %s" (Types.string_of fact) (Types.string_of expect));
   raise TypeError ;;
 
 let not_found loc s =
-  E.error loc.start (sp "Unbound value %s" (S.name s)); raise Not_found ;;
+  E.error loc (sp "Unbound value %s" (S.name s)); raise Not_found ;;
 
 let print_tenv tenv =
   S.iter tenv (fun sym ty ->
   (match tenv with
   | None -> ()
   | Some tenv -> print_tenv tenv);
-  E.error loc.start s; raise TypeError
+  E.error loc s; raise TypeError
 end ;;
 
 let rec look_act tenv sym =
       | Some _ -> error loc (sp "%s is not record type" (S.name ty_name))
     end
     | SeqExp (exps, loc) -> begin
-      let exps = List.map exps ~f:(fun (e, _) -> tr_exp e) in
+      let exps = List.map exps ~f:(fun e -> tr_exp e) in
       let ty =
         match List.last exps with
         | None -> UNIT
         List.fold_left fun_sigs ~init:venv ~f:(fun venv (fun_name, label, level, params, res_ty) ->
           let param_typs = List.map params ~f:(fun (_, ty) -> ty) in
           S.enter venv fun_name (Env.FunEntry (level, label, param_typs, res_ty))) in
-      
+
       List.iter2 decs fun_sigs ~f:(fun dec (_, _, level, param, res) ->
         let venv = List.fold_left2 param (remove_last @@ Tr.formals level) ~init:venv ~f:(fun venv (name, typ) acc ->
           S.enter venv name (Env.VarEntry (acc, typ))) in
         if not (ty_eq res body_ty) then
           type_error dec.fd_pos res body_ty
         else Tr.proc_entry_exit level body_exp);
-      
+
       (venv, tenv, [])
     | VarDec (name, escape, type_, rhs, loc) ->
       let {exp = rhs_exp; ty = rhs_ty} = trans_exp level None venv tenv rhs in
     | None -> not_found loc name
     | Some ty -> actual_type ~loc ty
   end
-  | RecordTy fields ->
+  | RecordTy (fields, _) ->
     let fields = List.fold_right fields ~init:[] ~f:(fun fi acc ->
       let ty =
         match S.look tenv fi.fi_typ with

src/translate.mli

 type exp
 
-(* access周り *)
-type level deriving (Show) ;;
+type level = {parent : level;
+              frame : Frame.frame;
+              id : unit ref} deriving (Show) ;;
 type access deriving (Show) ;;
 
 val outermost : level