This commit was manufactured by cvs2svn to create tag 'ocaml101'.1.01

git-svn-id: http://caml.inria.fr/svn/ocaml/release/1.01@884 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 0 insertions, 444 deletions

diff --git a/bytecomp/codegen.ml b/bytecomp/codegen.ml
deleted file mode 100644
index 0f2a88f1b1..0000000000
--- a/bytecomp/codegen.ml
+++ /dev/null
@@ -1,444 +0,0 @@
-(*  codegen.ml : translation of lambda terms to lists of instructions. *)
-
-open Misc
-open Asttypes
-open Lambda
-open Instruct
-
-(**** Label generation ****)
-
-let label_counter = ref 0
-
-let new_label () =
-  incr label_counter; !label_counter
-
-(**** Structure of the compilation environment. ****)
-
-type compilation_env =
-  { ce_stack: int Ident.tbl; (* Positions of variables in the stack *)
-    ce_heap: int Ident.tbl } (* Structure of the heap-allocated env *)
-
-(* The ce_stack component gives locations of variables residing 
-   in the stack. The locations are offsets w.r.t. the origin of the
-   stack frame.
-   The ce_heap component gives the positions of variables residing in the
-   heap-allocated environment. *)
-
-let empty_env =
-  { ce_stack = Ident.empty; ce_heap = Ident.empty }
-
-(* Add a stack-allocated variable *)
-
-let add_var id pos env =
-  { ce_stack = Ident.add id pos env.ce_stack;
-    ce_heap = env.ce_heap }
-
-(**** Examination of the continuation ****)
-
-(* Return a label to the beginning of the given continuation.
-   If the sequence starts with a branch, use the target of that branch
-   as the label, thus avoiding a jump to a jump. *)
-
-let label_code = function
-    Kbranch lbl :: _ as cont -> (lbl, cont)
-  | Klabel lbl :: _ as cont -> (lbl, cont)
-  | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont)
-
-(* Return a branch to the continuation. That is, an instruction that,
-   when executed, branches to the continuation or performs what the
-   continuation performs. We avoid generating branches to branches and
-   branches to returns. *)
-
-let make_branch cont =
-  match cont with
-    (Kbranch _ as branch) :: _ -> (branch, cont)
-  | (Kreturn _ as return) :: _ -> (return, cont)
-  | Kraise :: _ -> (Kraise, cont)
-  | Klabel lbl :: _ -> (Kbranch lbl, cont)
-  | _ -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont)
-
-(* Discard all instructions up to the next label.
-   This function is to be applied to the continuation before adding a
-   non-terminating instruction (branch, raise, return) in front of it. *)
-
-let rec discard_dead_code = function
-    [] -> []
-  | (Klabel _ | Krestart) :: _ as cont -> cont
-  | _ :: cont -> discard_dead_code cont
-
-(* Check if we're in tailcall position *)
-
-let rec is_tailcall = function
-    Kreturn _ :: _ -> true
-  | Klabel _ :: c -> is_tailcall c
-  | _ -> false
-
-(* Add a Kpop N instruction in front of a continuation *)
-
-let rec add_pop n cont =
-  if n = 0 then cont else
-    match cont with
-      Kpop m :: cont -> add_pop (n + m) cont
-    | Kreturn m :: cont -> Kreturn(n + m) :: cont
-    | Kraise :: _ -> cont
-    | _ -> Kpop n :: cont
-
-(* Add the constant "unit" in front of a continuation *)
-
-let add_const_unit = function
-    (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
-  | cont -> Kconst const_unit :: cont
-
-(**** Compilation of a lambda expression ****)
-
-(* The label to which Lstaticfail branches, and the stack size at that point.*)
-
-let lbl_staticfail = ref 0
-and sz_staticfail = ref 0
-
-(* Function bodies that remain to be compiled *)
-
-let functions_to_compile  =
-  (Stack.new () : (Ident.t * lambda * label * Ident.t list) Stack.t)
-
-(* Compile an expression.
-   The value of the expression is left in the accumulator.
-   env = compilation environment
-   exp = the lambda expression to compile
-   sz = current size of the stack frame
-   cont = list of instructions to execute afterwards
-   Result = list of instructions that evaluate exp, then perform cont. *)
-
-open Format
-
-let rec comp_expr env exp sz cont =
-  match exp with
-    Lvar id ->
-      begin try
-        let pos = Ident.find_same id env.ce_stack in
-        Kacc(sz - pos) :: cont
-      with Not_found ->
-      try
-        let pos = Ident.find_same id env.ce_heap in
-        Kenvacc(pos) :: cont
-      with Not_found ->
-        Ident.print id; print_newline();
-        fatal_error "Codegen.comp_expr: var"
-      end
-  | Lconst cst ->
-      Kconst cst :: cont
-  | Lapply(func, args) ->
-      let nargs = List.length args in
-      if is_tailcall cont then
-        comp_args env args sz
-          (Kpush :: comp_expr env func (sz + nargs)
-            (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
-      else
-        if nargs < 4 then
-          comp_args env args sz
-            (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
-        else begin
-          let (lbl, cont1) = label_code cont in
-          Kpush_retaddr lbl ::
-          comp_args env args (sz + 3)
-            (Kpush :: comp_expr env func (sz + 3 + nargs)
-                      (Kapply nargs :: cont1))
-        end
-  | Lfunction(param, body) ->
-      let lbl = new_label() in
-      let fv = free_variables exp in
-      Stack.push (param, body, lbl, fv) functions_to_compile;
-      comp_args env (List.map (fun n -> Lvar n) fv) sz
-        (Kclosure(lbl, List.length fv) :: cont)
-  | Llet(id, arg, body) ->
-      comp_expr env arg sz
-        (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
-          (add_pop 1 cont))
-  | Lletrec(([id, Lfunction(param, funct_body), _] as decl), let_body) ->
-      let lbl = new_label() in
-      let fv = free_variables (Lletrec(decl, lambda_unit)) in
-      Stack.push (param, funct_body, lbl, id :: fv) functions_to_compile;
-      comp_args env (List.map (fun n -> Lvar n) fv) sz
-        (Kclosurerec(lbl, List.length fv) :: Kpush ::
-          (comp_expr (add_var id (sz+1) env) let_body (sz+1)
-                     (add_pop 1 cont)))
-  | Lletrec(decl, body) ->
-      let ndecl = List.length decl in
-      let rec comp_decl new_env sz i = function
-          [] ->
-            comp_expr new_env body sz (add_pop ndecl cont)
-        | (id, exp, blocksize) :: rem ->
-            comp_expr new_env exp sz
-              (Kpush :: Kacc i :: Kupdate blocksize ::
-               comp_decl new_env sz (i-1) rem) in
-      let rec comp_init new_env sz = function
-          [] ->
-            comp_decl new_env sz ndecl decl
-        | (id, exp, blocksize) :: rem ->
-            Kdummy blocksize :: Kpush ::
-            comp_init (add_var id (sz+1) new_env) (sz+1) rem in
-      comp_init env sz decl
-  | Lprim(Pidentity, [arg]) ->
-      comp_expr env arg sz cont
-  | Lprim(Pnot, [arg]) ->
-      let newcont =
-        match cont with
-          Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
-        | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
-        | _ -> Kboolnot :: cont in
-      comp_expr env arg sz newcont
-  | Lprim(Psequand, [exp1; exp2]) ->
-      begin match cont with
-        Kbranchifnot lbl :: _ ->
-          comp_expr env exp1 sz (Kbranchifnot lbl ::
-            comp_expr env exp2 sz cont)
-      | Kbranchif lbl :: cont1 ->
-          let (lbl2, cont2) = label_code cont1 in
-          comp_expr env exp1 sz (Kbranchifnot lbl2 ::
-            comp_expr env exp2 sz (Kbranchif lbl :: cont2))
-      | _ ->
-          let (lbl, cont1) = label_code cont in
-          comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
-            comp_expr env exp2 sz cont1)
-      end
-  | Lprim(Psequor, [exp1; exp2]) ->
-      begin match cont with
-        Kbranchif lbl :: _ ->
-          comp_expr env exp1 sz (Kbranchif lbl ::
-            comp_expr env exp2 sz cont)
-      | Kbranchifnot lbl :: cont1 ->
-          let (lbl2, cont2) = label_code cont1 in
-          comp_expr env exp1 sz (Kbranchif lbl2 ::
-            comp_expr env exp2 sz (Kbranchifnot lbl :: cont2))
-      | _ ->
-          let (lbl, cont1) = label_code cont in
-          comp_expr env exp1 sz (Kstrictbranchif lbl ::
-            comp_expr env exp2 sz cont1)
-      end
-  | Lprim(Praise, [arg]) ->
-      comp_expr env arg sz (Kraise :: discard_dead_code cont)
-  | Lprim((Paddint | Psubint as prim), [arg; Lconst(Const_base(Const_int n))])
-    when n >= immed_min & n <= immed_max ->
-      let ofs = if prim == Paddint then n else -n in
-      comp_expr env arg sz (Koffsetint ofs :: cont)
-  | Lprim(p, args) ->
-      let instr =
-        match p with
-          Pgetglobal id -> Kgetglobal id
-        | Psetglobal id -> Ksetglobal id
-        | Pintcomp cmp -> Kintcomp cmp
-        | Pmakeblock tag -> Kmakeblock(List.length args, tag)
-        | Pfield n -> Kgetfield n
-        | Psetfield n -> Ksetfield n
-        | Pccall(name, n) -> Kccall(name, n)
-        | Pnegint -> Knegint
-        | Paddint -> Kaddint
-        | Psubint -> Ksubint
-        | Pmulint -> Kmulint
-        | Pdivint -> Kdivint
-        | Pmodint -> Kmodint
-        | Pandint -> Kandint
-        | Porint -> Korint
-        | Pxorint -> Kxorint
-        | Plslint -> Klslint
-        | Plsrint -> Klsrint
-        | Pasrint -> Kasrint
-        | Poffsetint n -> Koffsetint n
-        | Poffsetref n -> Koffsetref n
-        | Pnegfloat -> Kccall("neg_float", 1)
-        | Paddfloat -> Kccall("add_float", 2)
-        | Psubfloat -> Kccall("sub_float", 2)
-        | Pmulfloat -> Kccall("mul_float", 2)
-        | Pdivfloat -> Kccall("div_float", 2)
-        | Pfloatcomp Ceq -> Kccall("eq_float", 2)
-        | Pfloatcomp Cneq -> Kccall("neq_float", 2)
-        | Pfloatcomp Clt -> Kccall("lt_float", 2)
-        | Pfloatcomp Cgt -> Kccall("gt_float", 2)
-        | Pfloatcomp Cle -> Kccall("le_float", 2)
-        | Pfloatcomp Cge -> Kccall("ge_float", 2)
-        | Pgetstringchar -> Kgetstringchar
-        | Psetstringchar -> Ksetstringchar
-        | Pvectlength -> Kvectlength
-        | Pgetvectitem -> Kgetvectitem
-        | Psetvectitem -> Ksetvectitem
-        | Ptranslate tbl -> Ktranslate tbl
-        | _ -> fatal_error "Codegen.comp_expr: prim" in
-      comp_args env args sz (instr :: cont)
-  | Lcatch(body, Lstaticfail) ->
-      comp_expr env body sz cont
-  | Lcatch(body, handler) ->
-      let (branch1, cont1) = make_branch cont in
-      let (lbl_handler, cont2) = label_code (comp_expr env handler sz cont1) in
-      let saved_lbl_staticfail = !lbl_staticfail
-      and saved_sz_staticfail = !sz_staticfail in
-      lbl_staticfail := lbl_handler;
-      sz_staticfail := sz;
-      let cont3 = comp_expr env body sz (branch1 :: cont2) in
-      lbl_staticfail := saved_lbl_staticfail;
-      sz_staticfail := saved_sz_staticfail;
-      cont3
-  | Lstaticfail ->
-      add_pop (sz - !sz_staticfail)
-              (Kbranch !lbl_staticfail :: discard_dead_code cont)
-  | Ltrywith(body, id, handler) ->
-      let (branch1, cont1) = make_branch cont in
-      let lbl_handler = new_label() in
-      Kpushtrap lbl_handler :: 
-        comp_expr env body (sz+4) (Kpoptrap :: branch1 :: 
-          Klabel lbl_handler :: Kpush ::
-            comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1))
-  | Lifthenelse(cond, ifso, ifnot) ->
-      comp_binary_test env cond ifso ifnot sz cont
-  | Lsequence(exp1, exp2) ->
-      comp_expr env exp1 sz (comp_expr env exp2 sz cont)
-  | Lwhile(cond, body) ->
-      let lbl_loop = new_label() in
-      let lbl_test = new_label() in
-      Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
-        comp_expr env body sz
-          (Klabel lbl_test ::
-            comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont))
-  | Lfor(param, start, stop, dir, body) ->
-      let lbl_loop = new_label() in
-      let lbl_test = new_label() in
-      let offset = match dir with Upto -> 1 | Downto -> -1 in
-      let comp = match dir with Upto -> Cle | Downto -> Cge in
-      comp_expr env start sz
-        (Kpush :: comp_expr env stop (sz+1)
-          (Kpush :: Kbranch lbl_test ::
-           Klabel lbl_loop :: Kcheck_signals ::
-           comp_expr (add_var param (sz+1) env) body (sz+2)
-             (Kacc 1 :: Koffsetint offset :: Kassign 1 ::
-              Klabel lbl_test ::
-              Kacc 0 :: Kpush :: Kacc 2 :: Kintcomp comp ::
-              Kbranchif lbl_loop ::
-              add_const_unit (add_pop 2 cont))))
-  | Lswitch(arg, num_consts, consts, num_blocks, blocks) ->
-      (* To ensure stack balancing, we must have either sz = !sz_staticfail
-         or none of the actv.(i) contains an unguarded Lstaticfail. *)
-      let (branch, cont1) = make_branch cont in
-      let c = ref (discard_dead_code cont1) in
-      let act_consts = Array.new num_consts Lstaticfail in
-      List.iter (fun (n, act) -> act_consts.(n) <- act) consts;
-      let act_blocks = Array.new num_blocks Lstaticfail in
-      List.iter (fun (n, act) -> act_blocks.(n) <- act) blocks;
-      let lbl_consts = Array.new num_consts 0 in
-      let lbl_blocks = Array.new num_blocks 0 in
-      for i = num_blocks - 1 downto 0 do
-        let (lbl, c1) =
-          label_code(comp_expr env act_blocks.(i) sz (branch :: !c)) in
-        lbl_blocks.(i) <- lbl;
-        c := discard_dead_code c1
-      done;
-      for i = num_consts - 1 downto 0 do
-        let (lbl, c1) =
-          label_code(comp_expr env act_consts.(i) sz (branch :: !c)) in
-        lbl_consts.(i) <- lbl;
-        c := discard_dead_code c1
-      done;
-      comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
-  | Lshared(expr, lblref) ->
-      begin match !lblref with
-        None ->
-          let (lbl, cont1) = label_code(comp_expr env expr sz cont) in
-          lblref := Some lbl;
-          cont1
-      | Some lbl ->
-          Kbranch lbl :: discard_dead_code cont
-      end
-
-(* Compile a list of arguments [e1; ...; eN] to a primitive operation.
-   The values of eN ... e2 are pushed on the stack, e2 at top of stack,
-   then e3, then ... The value of e1 is left in the accumulator. *)
-
-and comp_args env argl sz cont =
-  comp_expr_list env (List.rev argl) sz cont
-
-and comp_expr_list env exprl sz cont =
-  match exprl with
-    [] -> cont
-  | [exp] -> comp_expr env exp sz cont
-  | exp :: rem ->
-      comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
-
-(* Compile an if-then-else test. *)
-
-and comp_binary_test env cond ifso ifnot sz cont =
-  let cont_cond =
-    if ifnot = Lconst const_unit then begin
-      let (lbl_end, cont1) = label_code cont in
-      Kbranchifnot lbl_end :: comp_expr env ifso sz cont1
-    end else
-    if ifso = Lstaticfail & sz = !sz_staticfail then
-      Kbranchif !lbl_staticfail :: comp_expr env ifnot sz cont
-    else
-    if ifnot = Lstaticfail & sz = !sz_staticfail then
-      Kbranchifnot !lbl_staticfail :: comp_expr env ifso sz cont
-    else begin
-      let (branch_end, cont1) = make_branch cont in
-      let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
-      Kbranchifnot lbl_not :: comp_expr env ifso sz (branch_end :: cont2)
-    end in
-  comp_expr env cond sz cont_cond
-
-(**** Compilation of functions ****)
-
-let comp_function (param, body, entry_lbl, free_vars) cont =
-  (* Uncurry the function body *)
-  let rec uncurry = function
-      Lfunction(param, body) ->
-        let (params, final) = uncurry body in (param :: params, final)
-    | Lshared(exp, lblref) ->
-        uncurry exp
-    | exp ->
-        ([], exp) in
-  let (params, fun_body) =
-    uncurry (Lfunction(param, body)) in
-  let arity = List.length params in
-  let rec pos_args pos delta = function
-      [] -> Ident.empty
-    | id :: rem -> Ident.add id pos (pos_args (pos+delta) delta rem) in
-  let env =
-    { ce_stack = pos_args arity (-1) params;
-      ce_heap = pos_args 0 1 free_vars } in
-  let cont1 =
-    comp_expr env fun_body arity (Kreturn arity :: cont) in
-  if arity > 1 then
-    Krestart :: Klabel entry_lbl :: Kgrab(arity - 1) :: cont1
-  else
-    Klabel entry_lbl :: cont1
-
-let comp_remainder cont =
-  let c = ref cont in
-  begin try
-    while true do
-      c := comp_function (Stack.pop functions_to_compile) !c
-    done
-  with Stack.Empty ->
-    ()
-  end;
-  !c
-
-(**** Compilation of a lambda phrase ****)
-
-let compile_implementation expr =
-  Stack.clear functions_to_compile;
-  label_counter := 0;
-  lbl_staticfail := 0;
-  sz_staticfail := 0;
-  let init_code = comp_expr empty_env expr 0 [] in
-  if Stack.length functions_to_compile > 0 then begin
-    let lbl_init = new_label() in
-    Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code)
-  end else
-    init_code
-
-let compile_phrase expr =
-  Stack.clear functions_to_compile;
-  label_counter := 0;
-  lbl_staticfail := 0;
-  sz_staticfail := 0;
-  let init_code = comp_expr empty_env expr 0 [Kstop] in
-  let fun_code = comp_remainder [] in
-  (init_code, fun_code)
-