1. camlspotter
  2. olfend

Commits

camlspotter  committed b924b58

tco stack depth limit simulatino

  • Participants
  • Parent commits 8c7c1ee
  • Branches tco

Comments (0)

Files changed (3)

File test.lam

View file
  • Ignore whitespace
 (letrec (sum (fun (x)
 		  (if (eq x 0) 0 (add x (sum (add x -1)))))))
 
-(sum 10)
+; This fails by stack overflow
+; (sum 10)
+(sum 8)
 
 ; sum_tail n = 1 + .. + n 
 (letrec (sum_tail (fun (st x)
 
 (sum_tail 0 10)
 
-; ; fibonacci
-; (letrec (fib (fun (x)
-; 	(if (eq x 1) 1
-; 	    (if (eq x 2) 1
-; 	        (add (fib (sub x 1))
-; 		     (fib (sub x 2))))))))
-; 
-; (fib 10)
+; fibonacci
+(letrec (fib (fun (x)
+	(if (eq x 1) 1
+	    (if (eq x 2) 1
+	        (add (fib (sub x 1))
+		     (fib (sub x 2))))))))
+
+(fib 10)
+
+; fails with stackoverflow
+; (fib 15)

File top.ml

View file
  • Ignore whitespace
   Format.eprintf "@.compile=@.%a@." Vm.Code.format codes;
   Format.eprintf "@.exec@.";
   let codes = Array.append existing_codes codes in
-  let state = { Vm.State.pc = pc; stack = []; env = venv; returns = [] } in
+  let state = { Vm.State.pc = pc; stack = Vm.Stack.empty; env = venv; returns = Vm.Stack.empty } in
   let v = Vm.Eval.run codes state in
   Format.eprintf "@.result=%a@." Sexplib.Sexp.pp_hum (Vm.Value.sexp_of_t v);
   Format.printf "%a@." Sexplib.Sexp.pp_hum (Vm.Value.sexp_of_t v);

File vm.ml

View file
  • Ignore whitespace
 *)
 end
 
-module Stack = struct
-  type t = Value.t list with sexp
+module Stack : sig
+  type 'a t with sexp
+  val empty : 'a t
+  val pop : 'a t -> ('a * 'a t) option
+  val pop2 : 'a t -> ('a * 'a * 'a t) option
+  val push : 'a -> 'a t -> 'a t
+  val push_with_limit : int -> 'a -> 'a t -> 'a t
+  val to_list : 'a t -> 'a list
+  val depth : 'a t -> int
+end = struct
+  type 'a t = int * 'a list with sexp
+  let empty = 0, []
+  let pop = function
+    | _, [] -> None
+    | n, x::xs -> Some (x, (n-1, xs))
+  let pop2 = function
+    | _, [] 
+    | _, [_] -> None 
+    | n, x::y::xs -> Some (x, y, (n-2, xs))
+  let push v (n,xs) = (n+1,v::xs)
+  let push_with_limit lim v (n,xs) = 
+    if n >= lim then failwith "stack overflow"
+    else (n+1,v::xs)
+  let to_list = snd
+  let depth = fst
 end
 
 module Code : sig
   type t = {
     pc : int;
     env : Env.t; (** heap *)
-    stack : Stack.t;
-    returns : (int * Env.t) list; (* return address and env list *)
+    stack : Value.t Stack.t;
+    returns : (int * Env.t) Stack.t; (* return address and env list *)
   } with sexp
 
-  type returns = (int * Env.t) list with sexp
+  type vstack = Value.t Stack.t with sexp
+  type returns = (int * Env.t) Stack.t with sexp
 
-  let initial = { pc= 0; env= Env.empty; stack= []; returns = []; }
+  let initial = { pc= 0; env= Env.empty; stack= Stack.empty; returns = Stack.empty; }
 
   let format ppf t = Sexplib.Sexp.pp_hum ppf (sexp_of_t t)
 end
     | _ -> 
         if !print_step then begin
           Format.eprintf "%d %a@." pc Sexplib.Sexp.pp_hum (Code.sexp_of_t code);
-          Format.eprintf "    STACK %a@." Sexplib.Sexp.pp_hum (Stack.sexp_of_t stack);
+          Format.eprintf "    STACK %a@." Sexplib.Sexp.pp_hum (State.sexp_of_vstack stack);
           Format.eprintf "    RETURNS %a@." Sexplib.Sexp.pp_hum (State.sexp_of_returns returns);
           Format.eprintf "    ENV %a@." Sexplib.Sexp.pp_hum (Env.sexp_of_t env);
         end;
         | C.Jmp l -> { state with pc = l.Label.adrs }
             
         | C.Jmpc l ->
-  	    begin match stack with
-  	    | [] -> failwith "stack empty at Jmpc"
-  	    | Value.Const (Const.Bool false) :: stack' -> { state with pc = l.Label.adrs; stack = stack' }
-  	    | Value.Const (Const.Bool true) :: stack' -> { state with pc = pc + 1; stack = stack' }
+  	    begin match Stack.pop stack with
+  	    | None -> failwith "stack empty at Jmpc"
+  	    | Some (Value.Const (Const.Bool false), stack') -> { state with pc = l.Label.adrs; stack = stack' }
+  	    | Some (Value.Const (Const.Bool true), stack') -> { state with pc = pc + 1; stack = stack' }
   	    | _ -> failwith "jmpc type error"
   	    end
               
         | C.Access ident ->
   	    { state with
               pc = pc + 1;
-              stack = Env.get env ident :: stack
+              stack = Stack.push (Env.get env ident) stack
             }
               
         | C.Push_prim (name, arity) ->
   	    { state with
               pc = pc + 1;
-  	      stack = Value.Prim (name, arity, []) :: stack
+  	      stack = Stack.push (Value.Prim (name, arity, [])) stack
             }
               
         | C.Push_const c ->
   	    { state with
               pc = pc + 1;
-  	      stack = Value.Const c :: stack
+  	      stack = Stack.push (Value.Const c) stack
             }
               
         | C.Push_closure (l, names) ->
   	    { state with
               pc = pc + 1;
-  	      stack = Value.Clos (l, names, env) :: stack (** CR jfuruse: it simply store the env
-                                                              which makes things are never gc'ed *)
+  	      stack = Stack.push (Value.Clos (l, names, env)) stack (** CR jfuruse: it simply store the env
+                                                                        which makes things are never gc'ed *)
             }
               
         | C.Push_fix (ident, l, names) ->
   	    { state with
               pc = pc + 1;
-  	      stack = Value.Fix (ident, l, names, env, names, env) :: stack (** CR jfuruse: it simply store the env
-                                                                                which makes things are never gc'ed *)
+  	      stack = Stack.push (Value.Fix (ident, l, names, env, names, env)) stack (** CR jfuruse: it simply store the env
+                                                                                          which makes things are never gc'ed *)
             }
               
         | C.Swap ident ->
-  	    begin match stack with
-  	    | [] -> failwith "stack empty at Swap"
-  	    | v::stack' ->
+  	    begin match Stack.pop stack with
+  	    | None -> failwith "stack empty at Swap"
+  	    | Some (v, stack') ->
                 { state with 
                   pc = pc + 1;
                   env = Env.push env ident v;
   	    end
               
         | C.Return ->
-  	    begin match stack, returns with
-  	    | [_], [] ->
+  	    begin match Stack.to_list stack, Stack.pop returns with
+  	    | [_], None ->
                 (* Stupid way of ending *)
   	        { state with pc = -1 }
-  	    | _, (adrs, env') :: returns' ->
+  	    | _, Some ((adrs, env'), returns') ->
   	        { state with 
                   pc = adrs;
                   env = env';
                   returns = returns';
                 }
   	    | [], _ -> failwith "short stack at Return"
-  	    | _, [] -> failwith "short returns at Return"
+  	    | _, None -> failwith "short returns at Return"
   	    end
 
         (* APPLY + RETURN *)              
         | C.Tail_apply ->
 
             let return ({ stack; returns; _ } as state) = 
-  	      match stack, returns with
-  	      | [_], [] ->
+  	      match Stack.to_list stack, Stack.pop returns with
+  	      | [_], None ->
                   (* Stupid way of ending *)
   	          { state with pc = -1 }
-  	      | _, (adrs, env') :: returns' ->
+  	      | _, Some ((adrs, env'), returns') ->
   	          { state with 
                     pc = adrs;
                     env = env';
                     returns = returns';
                   }
   	      | [], _ -> failwith "short stack at Return"
-  	      | _, [] -> failwith "short returns at Return"
+  	      | _, None -> failwith "short returns at Return"
             in
             
-  	    begin match stack with
-  	      | v :: Value.Prim (p, 1, args) :: stack -> (* primitive full app *)
-  	          return { state with
-                    pc = pc + 1;
-  	            stack = Prim.eval p (List.rev (v :: args)) :: stack
-                  }
-                    
-  	      | v :: Value.Prim (p, n, args) :: stack -> (* primitive partial app *)
-  	          return { state with
-                    pc = pc + 1;
-  	            stack = Value.Prim (p, n-1, v::args) :: stack
-                  }
-                    
-  	      | v :: Value.Clos(l, [var], env') :: stack' -> (* closure full app *)
-  	          { pc = l.Label.adrs;
-  	            env = Env.push env' var v;
-                    stack = stack';
-                    returns = returns
-                  }
-                    
-  	      | v :: Value.Clos(l, var::vars, env') :: stack' -> (* closure partial app *)
-  	          return { state with
-                    pc = pc + 1;
-  	            stack = Value.Clos(l, vars, Env.push env' var v) :: stack';
-                  }
-                    
-  	      | _ :: Value.Clos(_l, [], _env) :: _ -> failwith "malformed Clos at Apply"
+  	    begin match Stack.pop2 stack with
+  	    | Some (v, Value.Prim (p, 1, args), stack) -> (* primitive full app *)
+  	        return { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Prim.eval p (List.rev (v :: args))) stack
+                }
                   
-  	      | v :: Value.Fix(ident, l, args0, env0, [var], env') :: stack' -> (* closure full app *)
-  	          { pc = l.Label.adrs;
-                    stack = stack';
-  	            env = Env.push (Env.push env' var v) ident (Value.Fix(ident, l, args0, env0, args0, env0));
-                    returns = returns;
-                  }
-                    
-  	      | v :: Value.Fix(ident, l, argv0, env0, var::vars, env') :: stack' -> (* closure partial app *)
-  	          return { state with
-                    pc = pc + 1;
-  	            stack = Value.Fix(ident, l, argv0, env0, vars, Env.push env' var v) :: stack'
-                  }
-                    
-  	      | _ :: Value.Fix(_id, _l, _, _, [], _env) :: _ -> failwith "malformed Fix at Apply"
+  	    | Some (v, Value.Prim (p, n, args), stack) -> (* primitive partial app *)
+  	        return { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Prim (p, n-1, v::args)) stack
+                }
                   
-  	      | _ -> failwith "short stack at Apply"
-            end
-            
-
-
-(*
-            (* return is required for partial apply *)
-            let return ({ stack; returns; _ } as state) =
-  	      match stack, returns with
-  	      | [_], [] ->
-                  (* Stupid way of ending *)
-  	          { state with pc = -1 }
-  	      | _, (adrs, env') :: returns' ->
-  	          { state with 
-                    pc = adrs;
-                    env = env';
-                    returns = returns';
-                  }
-  	      | [], _ -> failwith "short stack at Return"
-  	      | _, [] -> failwith "short returns at Return"
-            in
-  	    begin match stack with
-  	    | v :: Value.Prim (p, 1, args) :: stack -> (* primitive full app *)
-                return { state with
-                  stack = Prim.eval p (List.rev (v :: args)) :: stack
-                }
-
-  	    | v :: Value.Prim (p, n, args) :: stack -> (* primitive partial app *)
-                return { state with
-                  stack = Value.Prim (p, n-1, v::args) :: stack 
-                }
-  
-  	    | v :: Value.Clos(l, [var], env') :: stack' -> (* closure full app *)
-  	        { state with
-                  pc = l.Label.adrs;
+  	    | Some (v, Value.Clos(l, [var], env'), stack') -> (* closure full app *)
+  	        { pc = l.Label.adrs;
   	          env = Env.push env' var v;
                   stack = stack';
+                  returns = returns
                 }
-  
-  	    | v :: Value.Clos(l, var::vars, env') :: stack' -> (* closure partial app *)
-                return { state with
-  	          stack = Value.Clos(l, vars, Env.push env' var v) :: stack';
+                  
+  	    | Some (v, Value.Clos(l, var::vars, env'), stack') -> (* closure partial app *)
+  	        return { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Clos(l, vars, Env.push env' var v)) stack';
                 }
-  
-  	    | _ :: Value.Clos(_l, [], _env) :: _ -> failwith "malformed Clos at Apply"
-  
-  	    | v :: Value.Fix(ident, l, args0, env0, [var], env') :: stack' -> (* closure full app *)
+                  
+  	    | Some (_, Value.Clos(_l, [], _env), _) -> failwith "malformed Clos at Apply"
+                
+  	    | Some (v, Value.Fix(ident, l, args0, env0, [var], env'), stack') -> (* closure full app *)
+  	        { pc = l.Label.adrs;
+                  stack = stack';
+  	          env = Env.push (Env.push env' var v) ident (Value.Fix(ident, l, args0, env0, args0, env0));
+                  returns = returns;
+                }
+                  
+  	    | Some (v, Value.Fix(ident, l, argv0, env0, var::vars, env'), stack') -> (* closure partial app *)
+  	        return { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Fix(ident, l, argv0, env0, vars, Env.push env' var v)) stack'
+                }
+                  
+  	    | Some (_, Value.Fix(_id, _l, _, _, [], _env), _) -> failwith "malformed Fix at Apply"
+                
+  	    | _ -> failwith "short stack at Apply"
+            end
+
+        | C.Apply ->
+  	    begin match Stack.pop2 stack with
+  	    | Some (v, Value.Prim (p, 1, args), stack) -> (* primitive full app *)
   	        { state with
-                  pc = l.Label.adrs;
+                  pc = pc + 1;
+  	          stack = Stack.push_with_limit 10 (Prim.eval p (List.rev (v :: args))) stack
+                }
+                  
+  	    | Some (v, Value.Prim (p, n, args), stack) -> (* primitive partial app *)
+  	        { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Prim (p, n-1, v::args)) stack
+                }
+                  
+  	    | Some (v, Value.Clos(l, [var], env'), stack') -> (* closure full app *)
+  	        { pc = l.Label.adrs;
+  	          env = Env.push env' var v;
+                  stack = stack';
+                  returns = Stack.push_with_limit 10 (pc + 1, env) returns (* store the return address *)
+                }
+                  
+  	    | Some (v, Value.Clos(l, var::vars, env'), stack') -> (* closure partial app *)
+  	        { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Clos(l, vars, Env.push env' var v)) stack';
+                }
+                  
+  	    | Some (_, Value.Clos(_l, [], _env), _) -> failwith "malformed Clos at Apply"
+                
+  	    | Some (v, Value.Fix(ident, l, args0, env0, [var], env'), stack') -> (* closure full app *)
+  	        { pc = l.Label.adrs;
+                  stack = stack';
   	          env = Env.push (Env.push env' var v) ident (Value.Fix(ident, l, args0, env0, args0, env0));
-                  stack = stack';
+                  returns = Stack.push_with_limit 10 (pc + 1, env) returns; (* store the return address *)
                 }
-  	    | v :: Value.Fix(ident, l, argv0, env0, var::vars, env') :: stack' -> (* closure partial app *)
-  	        return { state with
-  	          stack = Value.Fix(ident, l, argv0, env0, vars, Env.push env' var v) :: stack'
+                  
+  	    | Some (v, Value.Fix(ident, l, argv0, env0, var::vars, env'), stack') -> (* closure partial app *)
+  	        { state with
+                  pc = pc + 1;
+  	          stack = Stack.push (Value.Fix(ident, l, argv0, env0, vars, Env.push env' var v)) stack'
                 }
-  
-  	    | _ :: Value.Fix(_id, _l, _, _, [], _env) :: _ -> failwith "malformed Fix at Apply"
+                  
+  	    | Some (_, Value.Fix(_id, _l, _, _, [], _env), _) -> failwith "malformed Fix at Apply"
                 
   	    | _ -> failwith "short stack at Apply"
   	    end
-*)
-        | C.Apply ->
-  	    begin match stack with
-  	    | v :: Value.Prim (p, 1, args) :: stack -> (* primitive full app *)
-  	        { state with
-                  pc = pc + 1;
-  	          stack = Prim.eval p (List.rev (v :: args)) :: stack
-                }
-  
-  	    | v :: Value.Prim (p, n, args) :: stack -> (* primitive partial app *)
-  	        { state with
-                  pc = pc + 1;
-  	          stack = Value.Prim (p, n-1, v::args) :: stack
-                }
-  
-  	    | v :: Value.Clos(l, [var], env') :: stack' -> (* closure full app *)
-  	        { pc = l.Label.adrs;
-  	          env = Env.push env' var v;
-                  stack = stack';
-                  returns = (pc + 1, env) :: returns (* store the return address *)
-                }
-  
-  	    | v :: Value.Clos(l, var::vars, env') :: stack' -> (* closure partial app *)
-  	        { state with
-                  pc = pc + 1;
-  	          stack = Value.Clos(l, vars, Env.push env' var v) :: stack';
-                }
-  
-  	    | _ :: Value.Clos(_l, [], _env) :: _ -> failwith "malformed Clos at Apply"
-  
-  	    | v :: Value.Fix(ident, l, args0, env0, [var], env') :: stack' -> (* closure full app *)
-  	        { pc = l.Label.adrs;
-                  stack = stack';
-  	          env = Env.push (Env.push env' var v) ident (Value.Fix(ident, l, args0, env0, args0, env0));
-                  returns = (pc + 1, env) :: returns; (* store the return address *)
-                }
-  
-  	    | v :: Value.Fix(ident, l, argv0, env0, var::vars, env') :: stack' -> (* closure partial app *)
-  	        { state with
-                  pc = pc + 1;
-  	          stack = Value.Fix(ident, l, argv0, env0, vars, Env.push env' var v) :: stack'
-                }
-  
-  	    | _ :: Value.Fix(_id, _l, _, _, [], _env) :: _ -> failwith "malformed Fix at Apply"
-                
-  	    | _ -> failwith "short stack at Apply"
-  	    end
-  
+              
         | C.Pop_env ->
   	    begin match env with
   	    | _::env' -> { state with pc = pc + 1; env = env' }
     let rec loop state =
       let state = step codes state in
       if state.pc = -1 then 
-        match state.stack with
+        match Stack.to_list state.stack with
         | [v] -> v
         | _ -> assert false
       else loop state