(* Lambda code -> code avant finalisation *)

#open "am";;
#open "lambda";;
#open "global";;

let nblabel = ref 0;;
let new_label () = incr nblabel; !nblabel-1;;

let compile_stack = ref ([] : (Lambda*int) list);;
let add_to_compile x = compile_stack:=x::(!compile_stack);;
let compile_done () = (!compile_stack==[]);;
let get_to_compile () = match !compile_stack with t::q -> compile_stack:=q; t | _ -> failwith "get_to_compile";;


let maincode = ref [];;
let funccode = ref [];;

let rec add_drop k = function
  DropReturn n :: code -> DropReturn (n+k) :: code
| code -> let rec aux i code = if i=0 then code else aux (i-1) (Drop::code) in aux k code;;

let rec add_call = function
  DropReturn n :: suite -> CallTerm n ::suite
| code -> Call :: code
;;


let make_jump code = match code with
  DropReturn n :: _ -> DropReturn n, code
| (Jump _ as j) :: _ -> j, code
| (JumpTrue _ as j) :: _ -> j, code
| _ -> let l=new_label () in (Jump l, Label l :: code);;

let access loc suite = match loc with
  LocStack n -> Get n :: suite
| LocEnv n   -> EnvGet n :: suite
| LocDummy _ -> (* Dummy :: *) suite 
| LocGlobal n -> GetGlobal n :: suite
| LocImmInt n -> MakeInt n :: suite
| LocSpecial s -> 
  if s.VSLab<0 then
  begin
    s.VSLab<-new_label();
    add_to_compile (LSpecial s.VSCode,s.VSLab)
  end;
  MakeClosure (0,s.VSLab) :: suite
;;

let rec compile_lambda e suite = match e with
  LVar loc  -> (access loc) suite
| LConst n  -> MakeInt n :: suite
| LConstStr s -> MakeStr s :: suite
| LOpBin (i,a,b) -> compile_lambda a (Push::(compile_lambda b (i::suite)))
| LCall  (a,LVar (LocSpecial s)) -> compile_lambda a (s.VSCode suite)
| LCall  (a,b)   ->  compile_lambda a (Push::(compile_lambda b (add_call suite)))
| LOpUn (i,a)    -> compile_lambda a (i::suite)
| LITH  (t,a,b)  ->
        let (fin,suite)=make_jump suite in
        let sioui=new_label() in
        compile_lambda t (JumpTrue sioui::
         compile_lambda b (fin:: Label sioui::
          compile_lambda a suite))
| LSeq (a,b)    -> compile_lambda a (compile_lambda  b suite)
| LFunction (body, initenv) ->
        let labelbody=new_label() in
        add_to_compile (body, labelbody);
        it_list (fun code v -> (access v) (Push :: code))
        (MakeClosure (list_length initenv,labelbody) :: suite)
        initenv
| LLetDecl lambdas -> compile_let lambdas suite
| LLet (lambdas,body) -> compile_let lambdas 
        (compile_lambda body
         (add_drop (list_length lambdas) suite))

| LLetRecDecl (bodies,vars) -> compile_letrec bodies vars suite
| LLetRec (bodies,vars,inex) ->
        let suite=add_drop (list_length bodies) suite in
        let suite=compile_lambda inex suite in
        compile_letrec bodies vars suite
| LSpecial genere -> (Get 3) :: genere suite
| LMatch (e,matchs) -> 
      	let (fin,suite)=make_jump suite in
      	let suite=compile_matchs matchs fin suite in
	compile_lambda e suite

and compile_let lambdas suite =
        it_list (fun code l -> compile_lambda l (Push :: code)) suite lambdas
and compile_letrec bodies vars suite =
        let suite=it_list (fun code (LocDummy (k,i)) -> Update (i,k) :: code | code _ -> code) suite vars in
        let suite=it_list
         (fun code body -> let lab=new_label() in
             add_to_compile (body,lab);
             PushMakeCouple lab::code) suite bodies in
        let suite=MakeVect (list_length vars) :: suite in
        it_list (fun code v -> (access v) (Push :: code)) suite vars

and compile_match jmpfin suite = function
| MatchId l -> Push :: compile_lambda l (add_drop 1 (jmpfin :: suite))
| MatchConstr (n,l) -> 
    let labsuite=new_label () in
    TestConstr (n,labsuite) :: (compile_lambda l (add_drop 1 (jmpfin :: Label labsuite :: suite)))
| MatchConstConstr (n,l) -> 
    let labsuite=new_label () in
    TestConstConstr (n,labsuite) :: (compile_lambda l (jmpfin :: Label labsuite :: suite))

and compile_matchs matchs jmpfin suite =
  let matchs=rev matchs in
  it_list (fun suite m -> compile_match jmpfin suite m) (Stop (-1) :: suite) matchs;;


let compile_func (lamb,lab) =
  funccode:=Label lab :: (compile_lambda lamb (DropReturn 0::(!funccode)));;

let compile_topl lamb =
  maincode:=(compile_lambda lamb [])::(!maincode);
  while not compile_done () do
    compile_func (get_to_compile ());
  done;;  

let init_codes () =
  maincode:=[];
  funccode:=[];
  globalsp:=0;;

let compile_lambda_lab (lamb,lab) suite =
  Label lab :: (compile_lambda lamb suite);;

let compile_phrase e =
  nblabel:=0;
  compile_stack:=[];
  let rec compile_all suite =
    if compile_done () then suite
    else compile_all
     (compile_lambda_lab (get_to_compile ()) (DropReturn 0::suite))
  in
  let startlabel = new_label () in
  Jump startlabel ::
   (compile_all (compile_lambda_lab (e,startlabel) [Stop 0]));;