/*
 *  Neko Compiler
 *  Copyright (c)2005 Motion-Twin
 *
 *  This library is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU Lesser General Public
 *  License as published by the Free Software Foundation; either
 *  version 2.1 of the License, or (at your option) any later version.
 *
 *  This library is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 *  Lesser General Public License or the LICENSE file for more details.
 */
open Lexer;
open Neko.Ast;
open Neko.Bytecode;

type access {
	XEnv : int;
	XStack : int;
	XGlobal : int;
	XField : string;
	XIndex : int;
	XArray;
	XThis;
}

type label {
	lname : string;
	ltraps : int list;
	lstack : int;
	mutable lpos : int option;
	mutable lwait : (void -> void) list;
}

type globals {
	globals : (global,int) Hashtbl.t;
	gobjects : (string list,int) Hashtbl.t;
	mutable functions : (opcode array, (int,int) array, int , int) list;
	mutable gtable : global array;
	labels : (string,label) Hashtbl.t;
	hfiles : (string,int) Hashtbl.t;
	files : string array;
}

type context {
	g : globals;
	mutable ops : opcode array;
	mutable locals : (string,int) Map.t;
	mutable env : (string,int) Map.t;
	mutable nenv : int;
	mutable stack : int;
	mutable loop_limit : int;
	mutable limit : int;
	mutable traps : int list;
	mutable breaks : (void -> void, pos) list;
	mutable continues : (void -> void, pos) list;
	mutable pos : (int,int) array;
	mutable curpos : (int, int);
	mutable curfile : string;
}

type error_msg = string

exception Error : (error_msg , pos)

function error(e,p) {
	throw Error(e,p)
}

function error_msg(s) {
	s
}

function stack_delta(o) {
	match o {
	| AccNull
	| AccTrue
	| AccFalse
	| AccThis
	| AccInt _
	| AccStack _
	| AccGlobal _
	| AccEnv _
	| AccField _
	| AccBuiltin _
	| AccIndex _
	| JumpIf _
	| JumpIfNot _
	| Jump _
	| JumpTable _
	| Ret _
	| SetGlobal _
	| SetStack _
	| SetEnv _
	| SetThis
	| Bool
	| IsNull
	| IsNotNull
	| Not
	| Hash
	| TypeOf
	| New
	| AccStack0
	| AccStack1
	| AccIndex0
	| AccIndex1
		-> 0
	| Add
	| Sub
	| Mult
	| Div
	| Mod
	| Shl
	| Shr
	| UShr
	| Or
	| And
	| Xor
	| Eq
	| Neq
	| Gt
	| Gte
	| Lt
	| Lte
	| PhysCompare
		-> -1
	| AccArray -> -1
	| SetField _ | SetIndex _ | Compare -> -1
	| SetArray -> -2
	| Push -> 1
	| Pop x -> -x
	| Apply nargs | Call nargs | TailCall (nargs,_) -> -nargs
	| ObjCall nargs -> -(nargs + 1)
	| MakeEnv size | MakeArray size -> -size
	| Trap _ -> trap_stack_delta
	| EndTrap -> -trap_stack_delta
	}
}

function check_stack(ctx,stack,p) {
	if ctx.stack != stack then error "Stack alignment failure" p;
}

function pos(ctx) {
	Array.length ctx.ops
}

function set_pos(ctx,p) {
	if p.psource == ctx.curfile then {
		if p.pline != snd ctx.curpos then ctx.curpos := (fst ctx.curpos, p.pline);
	} else if p == Lexer.null_pos then {
		// nothing
	} else {
		var fid = try 
			Hashtbl.find ctx.g.hfiles p.psource 
		catch { Not_found -> 
			var fid = Array.length ctx.g.files;
			Array.add ctx.g.files p.psource;
			Hashtbl.add ctx.g.hfiles p.psource fid;
			fid;
		}
		ctx.curfile := p.psource;
		ctx.curpos := (fid,p.pline);
	}
}

function write(ctx,op) {
	ctx.stack := ctx.stack + stack_delta op;
	Array.add ctx.pos ctx.curpos;
	if op_param op then Array.add ctx.pos ctx.curpos;
	Array.add ctx.ops op;
}

function jmp(ctx) {
	var p = pos ctx;
	write ctx (Jump 0);
	function() {
		Array.set ctx.ops p Jump(pos ctx - p)
	}
}

function cjmp(cond,ctx) {
	var p = pos ctx;
	write ctx (Jump 0);
	function() {
		Array.set ctx.ops p (if cond then JumpIf else JumpIfNot)(pos ctx - p)
	}
}

function trap(ctx) {
	var p = pos ctx;
	write ctx (Trap 0);
	function() {
		Array.set ctx.ops p Trap(pos ctx - p)
	}
}

function goto(ctx,p) {
	write ctx Jump(p - pos ctx)
}

function global(ctx,g) {
	var ginf = ctx.g;
	try
		Hashtbl.find ginf.globals g
	catch {
		Not_found ->
			var gid = Array.length ginf.gtable;
			Hashtbl.add ginf.globals g gid;
			Array.add ginf.gtable g;
			gid
	}
}

function save_breaks(ctx) {
	var oldc = ctx.continues;
	var oldb = ctx.breaks;
	var oldl = ctx.loop_limit;
	ctx.loop_limit := ctx.stack;
	ctx.breaks := [];
	ctx.continues := [];
	(ctx , oldc, oldb , oldl)
}

function process_continues((ctx,oldc,_,_)) {
	List.iter (function((f,_)) { f() }) ctx.continues;
	ctx.continues := oldc
}

function process_breaks((ctx,_,oldb,oldl)) {
	List.iter (function((f,_)) { f() }) ctx.breaks;
	ctx.loop_limit := oldl;
	ctx.breaks := oldb
}

function check_breaks(ctx) {
	List.iter (function((_,p)) { error "Break outside a loop" p }) ctx.breaks;
	List.iter (function((_,p)) { error "Continue outside a loop" p }) ctx.continues
}

function make_array(p,el) {
	(ECall (EConst (Builtin "array"),p) el , p)
}

function get_cases_ints(cases) {
	var max = &(-1);
	var l = List.map (function((e,e2)) {
		match e {
		| (EConst (Int n),_) when n >= 0 ->
			if n > *max then max := n;
			(n,e2)
		| _ -> throw Exit
		}
	}) cases;
	// only create jump table if small or >10% cases matched
	var nmatches = List.length l;
	if nmatches < 3 then throw Exit;
	if *max >= 16 && (nmatches * 100) / (*max + 1) < 10 then throw Exit;
	(l,*max + 1)
}

function rec scan_labels(ctx,supported,in_block,e) {
	match fst e {
	| EFunction (args,e) ->
		var nargs = List.length args;
		var traps = ctx.traps;
		ctx.traps := [];
		ctx.stack := ctx.stack + nargs;
		scan_labels ctx supported false e;
		ctx.stack := ctx.stack - nargs;
		ctx.traps := traps
	| EBlock _ ->
		var old = ctx.stack;
		Neko.Ast.iter (scan_labels ctx supported true) e;
		ctx.stack := old
	| EVars l ->
		if !in_block then error "Variable declaration must be done inside a block" (snd e);
		List.iter (function((_,e)) {
			match e {
			| None -> ()
			| Some e -> scan_labels ctx supported false e
			};
			ctx.stack := ctx.stack + 1
		}) l
	| ELabel l when !supported ->
		error "Label is not supported in this part of the program" (snd e);
	| ELabel l when Hashtbl.exists ctx.g.labels l ->
		error ("Duplicate label " + l) (snd e)
	| ELabel l ->
		var label = {
			lname = l;
			ltraps = List.rev ctx.traps;
			lstack = ctx.stack;
			lpos = None;
			lwait = [];
		};
		Hashtbl.add ctx.g.labels l label
	| ETry (e,_,e2) ->
		ctx.stack := ctx.stack + trap_stack_delta;
		ctx.traps := ctx.stack :: ctx.traps;
		scan_labels ctx supported false e;
		ctx.stack := ctx.stack - trap_stack_delta;
		ctx.traps := match ctx.traps { [] -> assert() | _ :: l -> l };
		ctx.stack := ctx.stack + 1;
		scan_labels ctx supported false e2;
		ctx.stack := ctx.stack - 1;
	| EBinop ("=",e1,e2) ->
		function rec is_extended((e,_)) {
			match e {
			| EParenthesis e -> is_extended e
			| EArray _
			| EField _ ->
				true
			| _ ->
				false
			}
		};
		var ext = is_extended e1;
		if ext then ctx.stack := ctx.stack + 1;
		scan_labels ctx supported false e2;
		ctx.stack := ctx.stack + 1;
		scan_labels ctx supported false e1;
		ctx.stack := ctx.stack - (if ext then 2 else 1);
	| ECall ((EConst (Builtin x),_),el) when x != "array" && x != "apply" ->
		Neko.Ast.iter (scan_labels ctx false false) e
	| ECall ((EConst (Builtin "array"),_),e :: el)
	| ECall ((EConst (Builtin "apply"),_),e :: el)
	| ECall(e,el) ->
		List.iter (function(e) {
			scan_labels ctx supported false e;
			ctx.stack := ctx.stack + 1;
		}) el;
		scan_labels ctx supported false e;
		ctx.stack := ctx.stack - List.length el
	| EObject fl ->
		ctx.stack := ctx.stack + 2;
		List.iter (function((s,e)) {
			scan_labels ctx supported false e
		}) fl;
		ctx.stack := ctx.stack - 2;
	| ESwitch (ee,[(econd,exec)],eo) ->
		var p = snd e;
		scan_labels ctx supported false (EIf (EBinop "==" ee econd,p) exec eo,p)
	| ESwitch (e,cases,eo) ->
		scan_labels ctx supported false e;
		var delta = try { ignore(get_cases_ints cases); 0 } catch { Exit -> 1 };
		ctx.stack := ctx.stack + delta;
		List.iter (function((e1,e2)) {
			ctx.stack := ctx.stack + delta;
			scan_labels ctx supported false e1;
			ctx.stack := ctx.stack - delta;
			scan_labels ctx supported false e2;
		}) cases;
		match eo {
		| None -> ()
		| Some e -> scan_labels ctx supported false e
		}
		ctx.stack := ctx.stack - delta;
	| ENext (e1,e2) ->
		scan_labels ctx supported in_block e1;
		scan_labels ctx supported in_block e2;
	| EConst _
	| EContinue
	| EBreak _
	| EReturn _
	| EIf _
	| EWhile _
	| EParenthesis _ ->
		Neko.Ast.iter (scan_labels ctx supported false) e
	| EBinop (_,_,_)
	| EArray _
	| EField _
		->
		Neko.Ast.iter (scan_labels ctx false false) e
	}
}

function compile_constant(ctx,c,p) {
	match c {
	| True -> write ctx AccTrue
	| False -> write ctx AccFalse
	| Null -> write ctx AccNull
	| This -> write ctx AccThis
	| Int n -> write ctx (AccInt n)
	| Float f -> write ctx (AccGlobal (global ctx (GlobalFloat f)))
	| String s -> write ctx (AccGlobal (global ctx (GlobalString s)))
	| Builtin s ->
		match s {
		| "tnull" -> write ctx (AccInt 0)
		| "tint" -> write ctx (AccInt 1)
		| "tfloat" -> write ctx (AccInt 2)
		| "tbool" -> write ctx (AccInt 3)
		| "tstring" -> write ctx (AccInt 4)
		| "tobject" -> write ctx (AccInt 5)
		| "tarray" -> write ctx (AccInt 6)
		| "tfunction" -> write ctx (AccInt 7)
		| "tabstract" -> write ctx (AccInt 8)
		| s ->
			write ctx (AccBuiltin s)
		}
	| Ident s ->
		try {
			var l = Map.find ctx.locals s;
			if l <= ctx.limit then {
				var e = try {
					Map.find ctx.env s
				} catch { Not_found ->
					var e = ctx.nenv;
					ctx.nenv := ctx.nenv + 1;
					ctx.env := Map.add ctx.env s e;
					e
				};
				write ctx (AccEnv e);
			} else {
				var p = ctx.stack - l;
				write ctx (if p == 0 then AccStack0 else if p == 1 then AccStack1 else AccStack p);
			}
		} catch { Not_found ->
			var g = global ctx (GlobalVar s);
			write ctx (AccGlobal g)
		}
	}
}

function rec compile_access(ctx,e) {
	match fst e {
	| EConst (Ident s) ->
		try {
			var l = Map.find ctx.locals s;
			if l <= ctx.limit then {
				var e = try {
					Map.find ctx.env s
				} catch { Not_found ->
					var e = ctx.nenv;
					ctx.nenv := ctx.nenv + 1;
					ctx.env := Map.add ctx.env s e;
					e
				};
				XEnv e
			} else
				XStack l
		} catch { Not_found ->
			var g = global ctx (GlobalVar s);
			XGlobal g
		}
	| EField (e,f) ->
		compile ctx false e;
		write ctx Push;
		XField f
	| EArray (e1,(EConst (Int n),_)) ->
		compile ctx false e1;
		write ctx Push;
		XIndex n
	| EArray (ea,ei) ->
		compile ctx false ei;
		write ctx Push;
		compile ctx false ea;
		write ctx Push;
		XArray
	| EConst This ->
		XThis
	| _ ->
		error "Invalid access" (snd e)
	}
}

function rec compile_access_set(ctx,a) {
	match a {
	| XEnv n -> write ctx (SetEnv n)
	| XStack l -> write ctx (SetStack (ctx.stack - l))
	| XGlobal g -> write ctx (SetGlobal g)
	| XField f -> write ctx (SetField f)
	| XIndex i -> write ctx (SetIndex i)
	| XThis -> write ctx SetThis
	| XArray -> write ctx SetArray
	}
}

function rec compile_access_get(ctx,a) {
	match a {
	| XEnv n -> write ctx (AccEnv n)
	| XStack l -> write ctx (AccStack (ctx.stack - l))
	| XGlobal g -> write ctx (AccGlobal g)
	| XField f -> write ctx (AccField f)
	| XIndex i -> write ctx (AccIndex i)
	| XThis -> write ctx AccThis
	| XArray ->
		write ctx Push;
		write ctx (AccStack 2);
		write ctx AccArray
	}
}

function rec write_op(ctx,op,p) {
	match op {
	| "+" -> write ctx Add
	| "-" -> write ctx Sub
	| "/" -> write ctx Div
	| "*" -> write ctx Mult
	| "%" -> write ctx Mod
	| "<<" -> write ctx Shl
	| ">>" -> write ctx Shr
	| ">>>" -> write ctx UShr
	| "|" -> write ctx Or
	| "&" -> write ctx And
	| "^" -> write ctx Xor
	| "==" -> write ctx Eq
	| "!=" -> write ctx Neq
	| ">" -> write ctx Gt
	| ">=" -> write ctx Gte
	| "<" -> write ctx Lt
	| "<=" -> write ctx Lte
	| _ -> error "Unknown operation" p
	}
}

function rec compile_binop(ctx,tail,op,e1,e2,p) {
	match op {
	| "=" ->
		var a = compile_access ctx e1;
		compile ctx false e2;
		compile_access_set ctx a
	| "&&" ->
		compile ctx false e1;
		var jnext = cjmp false ctx;
		compile ctx tail e2;
		jnext()
	| "||" ->
		compile ctx false e1;
		var jnext = cjmp true ctx;
		compile ctx tail e2;
		jnext()
	| "++="
	| "--=" ->
		write ctx Push;
		var base = ctx.stack;
		var a = compile_access ctx e1;
		compile_access_get ctx a;
		write ctx SetStack(ctx.stack - base);
		write ctx Push;
		compile ctx false e2;
		write_op ctx (String.sub op 0 (String.length op - 2)) p;
		compile_access_set ctx a;
		write ctx (AccStack 0);
		write ctx (Pop 1);
	| "+="
	| "-="
	| "/="
	| "*="
	| "%="
	| "<<="
	| ">>="
	| ">>>="
	| "|="
	| "&="
	| "^=" ->
		var a = compile_access ctx e1;
		compile_access_get ctx a;
		write ctx Push;
		compile ctx false e2;
		write_op ctx (String.sub op 0 (String.length op - 1)) p;
		compile_access_set ctx a
	| _ ->
		match (op , e1 , e2) {
		| ("==" , _ , (EConst Null,_)) ->
			compile ctx false e1;
			write ctx IsNull
		| ("!=" , _ , (EConst Null,_)) ->
			compile ctx false e1;
			write ctx IsNotNull
		| ("==" , (EConst Null,_) , _) ->
			compile ctx false e2;
			write ctx IsNull
		| ("!=" , (EConst Null,_) , _) ->
			compile ctx false e2;
			write ctx IsNotNull
		| ("-", (EConst (Int 0),_) , (EConst (Int i),_)) ->
			compile ctx tail (EConst (Int (-i)),p)
		| _ ->
			compile ctx false e1;
			write ctx Push;
			compile ctx false e2;
			write_op ctx op p
		}
	}
}

function rec compile_function(main,params,e) {
	var ctx = {
		g = main.g;
		// reset
		ops = Array.create();
		pos = Array.create();
		breaks = [];
		continues = [];
		env = Map.empty();
		nenv = 0;
		traps = [];
		limit = main.stack;
		// dup
		stack = main.stack;
		locals = main.locals;
		loop_limit = main.loop_limit;
		curpos = main.curpos;
		curfile = main.curfile;
	};
	List.iter (function(v) {
		ctx.stack := ctx.stack + 1;
		ctx.locals := Map.add ctx.locals v ctx.stack;
	}) params;
	var s = ctx.stack;
	compile ctx true e;
	write ctx (Ret (ctx.stack - ctx.limit));
	check_stack ctx s (snd e);
	check_breaks ctx;
	// add function
	var gid = Array.length ctx.g.gtable;
	ctx.g.functions := (ctx.ops,ctx.pos,gid,List.length params) :: ctx.g.functions;
	Array.add ctx.g.gtable GlobalFunction(gid,-1);
	// environment
	if ctx.nenv > 0 then {
		var a = Array.make ctx.nenv "";
		Map.iter (function(v,i){ a.[i] := v }) ctx.env;
		Array.iter (function(v){
			compile_constant main (Ident v) snd(e);
			write main Push;
		}) a;
		write main (AccGlobal gid);
		write main (MakeEnv ctx.nenv);
	} else
		write main (AccGlobal gid);
}

function rec compile_builtin(ctx,tail,b,el,p) {
	match (b , el) {
	| ("istrue" , [e]) ->
		compile ctx false e;
		write ctx Bool
	| ("not" , [e]) ->
		compile ctx false e;
		write ctx Not
	| ("typeof" , [e]) ->
		compile ctx false e;
		write ctx TypeOf
	| ("hash" , [e]) ->
		compile ctx false e;
		write ctx Hash
	| ("new" , [e]) ->
		compile ctx false e;
		write ctx New
	| ("compare" , [e1;e2]) ->
		compile ctx false e1;
		write ctx Push;
		compile ctx false e2;
		write ctx Compare
	| ("pcompare" , [e1;e2]) ->
		compile ctx false e1;
		write ctx Push;
		compile ctx false e2;
		write ctx PhysCompare
	| ("goto" , [(EConst (Ident l) , _)] ) ->
		var l = try Hashtbl.find ctx.g.labels l catch { Not_found -> error ("Unknown label " + l) p };
		var os = ctx.stack;
		function rec loop(l1,l2) {
			match (l1,l2) {
			| (x :: l1 , y :: l2) when x == y -> loop l1 l2
			| _ -> (l1,l2)
			}
		}
		var straps , dtraps = loop List.rev(ctx.traps) l.ltraps;
		List.iter (function(l) {
			if ctx.stack != l then write ctx Pop(ctx.stack - l);
			write ctx EndTrap;
		}) List.rev(straps);
		var dtraps = List.map (function(l) {
			var l = l - trap_stack_delta;
			if l < ctx.stack then write ctx Pop(ctx.stack - l);
			while ctx.stack < l {
				write ctx Push;
			}
			trap ctx
		}) dtraps;
		if l.lstack < ctx.stack then write ctx Pop(ctx.stack - l.lstack);
		while l.lstack > ctx.stack { write ctx Push };
		ctx.stack := os;
		match l.lpos {
		| None -> l.lwait := jmp ctx :: l.lwait
		| Some p -> write ctx (Jump p)
		};
		List.iter (function(t) {
			t();
			write ctx Push;
			compile_constant ctx (Builtin "throw") p;
			write ctx (Call 1);
			// insert an infinite loop in order to
			// comply with bytecode checker
			ignore(jmp ctx)
		}) dtraps;
	| ("goto" , _) ->
		error "Invalid $goto statement" p
	| ("array",e :: el) ->
		var count = List.length el;
		// a single function can't have >128 stack
		if count > 120 - ctx.stack && count > 8 then {
			// split in 8 and recurse
			var part = count >> 3;
			function rec loop(el,acc,count) {
				match el {
				| [] -> [List.rev acc]
				| e :: l ->
					if count == part then
						List.rev(acc) :: loop el [] 0
					else
						loop l (e :: acc) (count + 1)
				}
			}
			var arr = make_array p (List.map make_array(p) (loop (e :: el) [] 0));
			compile_builtin ctx tail "aconcat" [arr] p;
		} else {
			List.iter (function(e) {
				compile ctx false e;
				write ctx Push;
			}) el;
			compile ctx false e;
			write ctx (MakeArray count);
		}
	| ("apply",e :: el) ->
		List.iter (function(e) {
			compile ctx false e;
			write ctx Push;
		}) el;
		compile ctx false e;
		var nargs = List.length el;
		if nargs > 0 then write ctx (Apply nargs);
	| _ ->
		List.iter (function(e) {
			compile ctx false e;
			write ctx Push;
		}) el;
		compile_constant ctx (Builtin b) p;
		if tail then
			write ctx TailCall(List.length el,ctx.stack - ctx.limit)
		else
			write ctx Call(List.length el)
	}
}

function rec compile(ctx,tail,(e,p)) {
	set_pos ctx p;
	match e {
	| EConst c ->
		compile_constant ctx c p
	| EBlock [] ->
		write ctx AccNull
	| EBlock el ->
		var locals = ctx.locals;
		var stack = ctx.stack;
		function rec loop(el) {
			match el {
			| [] -> assert()
			| [e] -> compile ctx tail e
			| [e; (ELabel _,_) as f] ->
				compile ctx tail e;
				compile ctx tail f
			| e :: el ->
				compile ctx false e;
				loop el
			}
		}
		loop el;
		if stack < ctx.stack then write ctx (Pop (ctx.stack - stack));
		check_stack ctx stack p;
		ctx.locals := locals
	| EParenthesis e ->
		compile ctx tail e
	| EField (e,f) ->
		compile ctx false e;
		write ctx (AccField f)
	| ECall (e,a :: b :: c :: d :: x1 :: x2 :: l) when match e { (EConst (Builtin "array"),_) -> false | _ -> true } ->
		var call = (EConst (Builtin "call"),p);
		var args = (ECall (EConst (Builtin "array"),p) (a :: b :: c :: d :: x1 :: x2 :: l),p);
		match e {
		| (EField (e,name) , p2) ->
			var locals = ctx.locals;
			var etmp = (EConst (Ident "$tmp"),p2);
			compile ctx false (EVars [("$tmp",Some e)],p2);
			compile ctx tail (ECall call [(EField etmp name,p2);etmp;args], p);
			write ctx (Pop 1);
			ctx.locals := locals
		| _ ->
			compile ctx tail (ECall call [e; (EConst This,p); args],p);
		}
	| ECall ((EConst (Builtin b),_),el) ->
		compile_builtin ctx tail b el p
	| ECall ((EField (e,f),_),el) ->
		List.iter (function(e) {
			compile ctx false e;
			write ctx Push;
		}) el;
		compile ctx false e;
		write ctx Push;
		write ctx (AccField f);
		write ctx ObjCall(List.length el)
	| ECall (e,el) ->
		List.iter (function(e) {
			compile ctx false e;
			write ctx Push;
		}) el;
		compile ctx false e;
		if tail then
			write ctx TailCall(List.length el,ctx.stack - ctx.limit)
		else
			write ctx Call(List.length el)
	| EArray (e1,(EConst (Int n),_)) ->
		compile ctx false e1;
		write ctx (if n == 0 then AccIndex0 else if n == 1 then AccIndex1 else AccIndex n)
	| EArray (e1,e2) ->
		compile ctx false e1;
		write ctx Push;
		compile ctx false e2;
		write ctx AccArray
	| EVars vl ->
		List.iter (function((v,o)) {
			match o {
			| None -> write ctx AccNull
			| Some e -> compile ctx false e
			};
			write ctx Push;
			ctx.locals := Map.add ctx.locals v ctx.stack;
		}) vl
	| EWhile (econd,e,NormalWhile) ->
		var start = pos ctx;
		compile ctx false econd;
		var jend = cjmp false ctx;
		var save = save_breaks ctx;
		compile ctx false e;
		process_continues save;
		goto ctx start;
		process_breaks save;
		jend();
	| EWhile (econd,e,DoWhile) ->
		var start = pos ctx;
		var save = save_breaks ctx;
		compile ctx false e;
		process_continues save;
		compile ctx false econd;
		write ctx (JumpIf (start - pos ctx));
		process_breaks save
	| EIf (e,e1,e2) ->
		var stack = ctx.stack;
		compile ctx false e;
		var jelse = cjmp false ctx;
		compile ctx tail e1;
		check_stack ctx stack p;
		match e2 {
		| None ->
			jelse()
		| Some e2 ->
			var jend = jmp ctx;
			jelse();
			compile ctx tail e2;
			check_stack ctx stack p;
			jend()
		};
	| ETry (e,v,ecatch) ->
		var trap = trap ctx;
		var breaks = ctx.breaks;
		var continues = ctx.continues;
		ctx.breaks := [];
		ctx.continues := [];
		ctx.traps := ctx.stack :: ctx.traps;
		compile ctx false e;
		if ctx.breaks != [] then error "Break in try...catch is not allowed" p;
		if ctx.continues != [] then error "Continue in try...catch is not allowed" p;
		ctx.breaks := breaks;
		ctx.continues := continues;
		write ctx EndTrap;
		ctx.traps := match ctx.traps { [] -> assert() | _ :: l -> l };
		var jend = jmp ctx;
		trap();
		write ctx Push;
		var locals = ctx.locals;
		ctx.locals := Map.add ctx.locals v ctx.stack;
		compile ctx tail ecatch;
		write ctx (Pop 1);
		ctx.locals := locals;
		jend()
	| EBinop (op,e1,e2) ->
		compile_binop ctx tail op e1 e2 p
	| EReturn e ->
		match e { None -> write ctx AccNull | Some e -> compile ctx (ctx.traps == []) e };
		var i = &0;
		var stack = ctx.stack;
		List.iter (function(t) {
			if ctx.stack > t then write ctx Pop(ctx.stack - t);
			write ctx EndTrap;
		}) ctx.traps;
		write ctx (Ret (ctx.stack - ctx.limit));
		ctx.stack := stack
	| EBreak e ->
		match e {
		| None -> ()
		| Some e -> compile ctx false e
		};
		if ctx.loop_limit != ctx.stack then {
			var s = ctx.stack;
			write ctx Pop(ctx.stack - ctx.loop_limit);
			ctx.stack := s;
		}
		ctx.breaks := (jmp ctx , p) :: ctx.breaks
	| EContinue ->
		if ctx.loop_limit != ctx.stack then {
			var s = ctx.stack;
			write ctx Pop(ctx.stack - ctx.loop_limit);
			ctx.stack := s;
		}
		ctx.continues := (jmp ctx , p) :: ctx.continues
	| EFunction (params,e) ->
		compile_function ctx params e
	| ENext (e1,e2) ->
		compile ctx false e1;
		compile ctx tail e2
	| EObject [] ->
		write ctx AccNull;
		write ctx New
	| EObject fl ->
		var fields = List.sort compare (List.map fst fl);
		var id = try
			Hashtbl.find ctx.g.gobjects fields
		catch { Not_found ->
			var id = global ctx (GlobalVar ("o:" + Hashtbl.length ctx.g.gobjects));
			Hashtbl.add ctx.g.gobjects fields id;
			id
		};
		write ctx (AccGlobal id);
		write ctx New;
		write ctx Push;
		List.iter (function((f,e)) {
			write ctx Push;
			compile ctx false e;
			write ctx (SetField f);
			write ctx AccStack0;
		}) fl;
		write ctx (Pop 1)
	| ELabel l ->
		var l = try Hashtbl.find ctx.g.labels l catch { Not_found -> assert() };
		if ctx.stack != l.lstack || List.rev(ctx.traps) != l.ltraps then error (sprintf "Label failure %d %d %s %s" (ctx.stack,l.lstack,string List.rev(ctx.traps),string l.ltraps)) p;
		List.iter (function(f) { f() }) l.lwait;
		l.lwait := [];
		l.lpos := Some (pos ctx)
	| ESwitch (e,[(econd,exec)],eo) ->
		compile ctx tail (EIf (EBinop "==" e econd,p) exec eo,p)
	| ESwitch (e,cases,eo) ->
		try {
			var ints , size = get_cases_ints cases;
			compile ctx false e;
			write ctx (JumpTable size);
			var tbl = Array.make size None;
			List.iter (function((i,e)) {
				tbl.[i] := Some e;
			}) ints;
			var tbl = Array.map (function(e) { (jmp ctx,e) }) tbl;
			Array.iter (function((j,e)) {
				if e == None then j()
			}) tbl;
			match eo {
			| None -> write ctx AccNull
			| Some e -> compile ctx tail e
			}
			var jump_end = jmp ctx;
			var tbl = Array.map (function((j,e)) {
				match e {
				| Some e ->
					j();
					compile ctx tail e;
					jmp ctx
				| None ->
					function() { }
				}
			}) tbl;
			jump_end();
			Array.iter (function(j) { j() }) tbl
		} catch { Exit ->
			compile ctx false e;
			write ctx Push;
			var jumps = List.map (function((e1,e2)) {
				write ctx AccStack0;
				write ctx Push;
				compile ctx false e1;
				write ctx Eq;
				(cjmp true ctx , e2)
			}) cases;
			match eo {
			| None -> write ctx AccNull
			| Some e -> compile ctx tail (EBlock [e],p)
			}
			var jump_end = jmp ctx;
			var jumps = List.map (function((j,e)) {
				j();
				compile ctx tail (EBlock [e],p);
				jmp ctx;
			}) jumps;
			jump_end();
			List.iter (function(j) { j() }) jumps;
			write ctx (Pop 1)
		}
	}
}

function compile(ast) {
	var g = {
		globals = Hashtbl.create();
		gobjects = Hashtbl.create();
		gtable = Array.create();
		functions = [];
		labels = Hashtbl.create();
		hfiles = Hashtbl.create();
		files = Array.create();
	};
	var ctx = {
		g = g;
		stack = 0;
		loop_limit = 0;
		limit = -1;
		locals = Map.empty();
		ops = Array.create();
		breaks = [];
		continues = [];
		env = Map.empty();
		nenv = 0;
		traps = [];
		pos = Array.create();
		curpos = (0,0);
		curfile = "_";
	};
	scan_labels ctx true true ast;
	compile ctx false ast;
	check_breaks ctx;
	if g.functions != [] || Hashtbl.length g.gobjects != 0 then {
		var ctxops = ctx.ops;
		var ctxpos = ctx.pos;
		var ops = Array.create();
		var pos = Array.create();
		ctx.pos := pos;
		ctx.ops := ops;
		write ctx (Jump 0);
		List.iter (function((fops,fpos,gid,nargs)) {
			Array.set g.gtable gid GlobalFunction(Array.length ops,nargs);
			Array.append fops ops;
			Array.append fpos pos;
		}) (List.rev g.functions);
		Array.set ops 0 (Jump (Array.length ops));
		Hashtbl.iter (function(fl,g) {
			write ctx AccNull;
			write ctx New;
			write ctx (SetGlobal g);
			List.iter (function(f) {
				write ctx (AccGlobal g);
				write ctx Push;
				write ctx (SetField f);
			}) fl
		}) g.gobjects;
		Array.append ctxpos pos;
		Array.append ctxops ops;
	};
	Array.add g.gtable (GlobalDebug ctx.g.files ctx.pos);
	(g.gtable, ctx.ops)
}
