Anonymous avatar Anonymous committed 41f41b5

Codage des constructeurs constants avec Const_pointer
Optimisation de match (a,b) with (p1,p2) ->
Renommage de codegen -> bytegen, linker -> bytelink.
emitcode: cas Kdummy 0.

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

Comments (0)

Files changed (12)

bytecomp/bytegen.ml

+(*  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
+
+(**** Auxiliary for compiling "let rec" ****)
+
+let rec size_of_lambda = function
+    Lfunction(param, body) as funct ->
+      1 + IdentSet.cardinal(free_variables funct)
+  | Lprim(Pmakeblock tag, args) ->
+      List.length args
+  | Llet(id, arg, body) ->
+      size_of_lambda body
+  | _ ->
+      fatal_error "Codegen.size_of_lambda"
+
+(**** 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. *)
+
+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 = IdentSet.elements(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 =
+        IdentSet.elements (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 decl_size =
+        List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) 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_size
+        | (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_size
+  | 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)
+

bytecomp/bytegen.mli

+(* Generation of bytecode from lambda terms *)
+
+open Lambda
+open Instruct
+
+val compile_implementation: lambda -> instruction list
+val compile_phrase: lambda -> instruction list * instruction list
+

bytecomp/bytelink.ml

+(* Link a set of .cmo files and produce a bytecode executable. *)
+
+open Sys
+open Misc
+open Config
+open Emitcode
+
+type error =
+    File_not_found of string
+  | Not_an_object_file of string
+  | Symbol_error of string * Symtable.error
+  | Inconsistent_import of string * string * string
+  | Custom_runtime
+
+exception Error of error
+
+type link_action =
+    Link_object of string * compilation_unit
+      (* Name of .cmo file and descriptor of the unit *)
+  | Link_archive of string * compilation_unit list
+      (* Name of .cma file and descriptors of the units to be linked. *)
+
+(* First pass: determine which units are needed *)
+
+module IdentSet =
+  Set.Make(struct
+    type t = Ident.t
+    let compare = compare
+  end)
+
+let missing_globals = ref IdentSet.empty
+
+let is_required (rel, pos) =
+  match rel with
+    Reloc_setglobal id ->
+      IdentSet.mem id !missing_globals
+  | _ -> false
+
+let add_required (rel, pos) =
+  match rel with
+    Reloc_getglobal id ->
+      missing_globals := IdentSet.add id !missing_globals
+  | _ -> ()
+
+let remove_required (rel, pos) =
+  match rel with
+    Reloc_setglobal id ->
+      missing_globals := IdentSet.remove id !missing_globals
+  | _ -> ()
+
+let scan_file tolink obj_name =
+  let file_name =
+    try
+      find_in_path !load_path obj_name
+    with Not_found ->
+      raise(Error(File_not_found obj_name)) in
+  let ic = open_in_bin file_name in
+  try
+    let buffer = String.create (String.length cmo_magic_number) in
+    really_input ic buffer 0 (String.length cmo_magic_number);
+    if buffer = cmo_magic_number then begin
+      (* This is a .cmo file. It must be linked in any case.
+         Read the relocation information to see which modules it
+         requires. *)
+      let compunit_pos = input_binary_int ic in  (* Go to descriptor *)
+      seek_in ic compunit_pos;
+      let compunit = (input_value ic : compilation_unit) in
+      close_in ic;
+      List.iter add_required compunit.cu_reloc;
+      Link_object(file_name, compunit) :: tolink
+    end
+    else if buffer = cma_magic_number then begin
+      (* This is an archive file. Each unit contained in it will be linked
+         in only if needed. *)
+      let pos_toc = input_binary_int ic in    (* Go to table of contents *)
+      seek_in ic pos_toc;
+      let toc = (input_value ic : compilation_unit list) in
+      close_in ic;
+      let required =
+        List.fold_left
+          (fun reqd compunit ->
+            if List.exists is_required compunit.cu_reloc
+            or !Clflags.link_everything
+            then begin
+              List.iter remove_required compunit.cu_reloc;
+              List.iter add_required compunit.cu_reloc;
+              compunit :: reqd
+            end else
+              reqd)
+          [] toc in
+      Link_archive(file_name, required) :: tolink
+    end
+    else raise(Error(Not_an_object_file file_name))
+  with x ->
+    close_in ic; raise x
+
+(* Second pass: link in the required units *)
+
+(* Consistency check between interfaces *)
+
+let crc_interfaces = (Hashtbl.new 17 : (string, string * int) Hashtbl.t)
+
+let check_consistency file_name cu =
+  List.iter
+    (fun (name, crc) ->
+      try
+        let (auth_name, auth_crc) = Hashtbl.find crc_interfaces name in
+        if crc <> auth_crc then
+          raise(Error(Inconsistent_import(name, file_name, auth_name)))
+      with Not_found ->
+        Hashtbl.add crc_interfaces name (file_name, crc))
+    cu.cu_interfaces
+
+(* Link in a compilation unit *)
+
+let link_compunit outchan inchan file_name compunit =
+  check_consistency file_name compunit;
+  seek_in inchan compunit.cu_pos;
+  let code_block = String.create compunit.cu_codesize in
+  really_input inchan code_block 0 compunit.cu_codesize;
+  Symtable.patch_object code_block compunit.cu_reloc;
+  output outchan code_block 0 compunit.cu_codesize
+
+(* Link in a .cmo file *)
+
+let link_object outchan file_name compunit =
+  let inchan = open_in_bin file_name in
+  try
+    link_compunit outchan inchan file_name compunit;
+    close_in inchan
+  with
+    Symtable.Error msg ->
+      close_in inchan; raise(Error(Symbol_error(file_name, msg)))
+  | x ->
+      close_in inchan; raise x
+
+(* Link in a .cma file *)
+
+let link_archive outchan file_name units_required =
+  let inchan = open_in_bin file_name in
+  try
+    List.iter (link_compunit outchan inchan file_name) units_required;
+    close_in inchan
+  with
+    Symtable.Error msg ->
+      close_in inchan; raise(Error(Symbol_error(file_name, msg)))
+  | x ->
+      close_in inchan; raise x
+
+(* Link in a .cmo or .cma file *)
+
+let link_file outchan = function
+    Link_object(file_name, unit) -> link_object outchan file_name unit
+  | Link_archive(file_name, units) -> link_archive outchan file_name units
+
+(* Create a bytecode executable file *)
+
+let link_bytecode objfiles exec_name copy_header =
+  let objfiles = "stdlib.cma" :: objfiles in
+  let tolink =
+    List.fold_left scan_file [] (List.rev objfiles) in
+  let outchan =
+    open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777
+                 exec_name in
+  try
+    (* Copy the header *)
+    if copy_header then begin
+      try
+        let inchan = open_in_bin (find_in_path !load_path "cslheader") in
+        copy_file inchan outchan;
+        close_in inchan
+      with Not_found | Sys_error _ -> ()
+    end;
+    (* The bytecode *)
+    let pos1 = pos_out outchan in
+    Symtable.init();
+    Hashtbl.clear crc_interfaces;
+    List.iter (link_file outchan) tolink;
+    (* The final STOP instruction *)
+    output_byte outchan Opcodes.opSTOP;
+    output_byte outchan 0; output_byte outchan 0; output_byte outchan 0;
+    (* The table of global data *)
+    let pos2 = pos_out outchan in
+    output_compact_value outchan (Symtable.initial_global_table());
+    (* The List.map of global identifiers *)
+    let pos3 = pos_out outchan in
+    Symtable.output_global_map outchan;
+    (* The trailer *)
+    let pos4 = pos_out outchan in
+    output_binary_int outchan (pos2 - pos1);
+    output_binary_int outchan (pos3 - pos2);
+    output_binary_int outchan (pos4 - pos3);
+    output_binary_int outchan 0;
+    output_string outchan exec_magic_number;
+    close_out outchan
+  with x ->
+    close_out outchan;
+    remove_file exec_name;
+    raise x
+
+(* Main entry point (build a custom runtime if needed) *)
+
+let link objfiles =
+  if not !Clflags.custom_runtime then
+    link_bytecode objfiles !Clflags.exec_name true
+  else begin
+    let bytecode_name = temp_file "camlcode" "" in
+    let prim_name = temp_file "camlprim" ".c" in
+    try
+      link_bytecode objfiles bytecode_name false;
+      Symtable.output_primitives prim_name;
+      if Sys.command
+          (Printf.sprintf
+           "%s -I%s -o %s %s %s -L%s %s -lcamlrun %s"
+           Config.c_compiler
+           Config.standard_library
+           !Clflags.exec_name
+           (String.concat " " (List.rev !Clflags.ccopts))
+           prim_name
+           Config.standard_library
+           (String.concat " " (List.rev !Clflags.ccobjs))
+           Config.c_libraries)
+         <> 0
+      or Sys.command ("strip " ^ !Clflags.exec_name) <> 0
+      then raise(Error Custom_runtime);
+      let oc =
+        open_out_gen [Open_wronly; Open_append; Open_binary] 0
+                     !Clflags.exec_name in
+      let ic = open_in_bin bytecode_name in
+      copy_file ic oc;
+      close_in ic;
+      close_out oc;
+      remove_file bytecode_name;
+      remove_file prim_name
+    with x ->
+      remove_file bytecode_name;
+      remove_file prim_name;
+      raise x
+  end
+
+(* Error report *)
+
+open Format
+
+let report_error = function
+    File_not_found name ->
+      print_string "Cannot find file "; print_string name
+  | Not_an_object_file name ->
+      print_string "The file "; print_string name;
+      print_string " is not a bytecode object file"
+  | Symbol_error(name, err) ->
+      print_string "Error while linking "; print_string name; print_string ":";
+      print_space();
+      Symtable.report_error err
+  | Inconsistent_import(intf, file1, file2) ->
+      open_hvbox 0;
+      print_string "Files "; print_string file1; print_string " and ";
+      print_string file2; print_space();
+      print_string "make inconsistent assumptions over interface ";
+      print_string intf;
+      close_box()
+  | Custom_runtime ->
+      print_string "Error while building custom runtime system"
+

bytecomp/bytelink.mli

+(* Link .cmo files and produce a bytecode executable. *)
+
+val link: string list -> unit
+
+val check_consistency: string -> Emitcode.compilation_unit -> unit
+
+type error =
+    File_not_found of string
+  | Not_an_object_file of string
+  | Symbol_error of string * Symtable.error
+  | Inconsistent_import of string * string * string
+  | Custom_runtime
+
+exception Error of error
+
+val report_error: error -> unit

bytecomp/emitcode.ml

           else (out opCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opCONSTINT; out_int (Char.code c)
+      | Const_pointer i ->
+          if i >= 0 & i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i)
       | Const_block(t, []) ->
           if t = 0 then out opATOM0 else (out opATOM; out_int t)
       | _ ->
       if n < 4 then out(opGETFIELD0 + n) else (out opGETFIELD; out_int n)
   | Ksetfield n ->
       if n < 4 then out(opSETFIELD0 + n) else (out opSETFIELD; out_int n)
-  | Kdummy n -> out opDUMMY; out_int n
+  | Kdummy n ->
+      if n = 0 then out opATOM0 else (out opDUMMY; out_int n)
   | Kupdate n -> out opUPDATE
   | Kvectlength -> out opVECTLENGTH
   | Kgetvectitem -> out opGETVECTITEM

bytecomp/lambda.ml

 type structured_constant =
     Const_base of constant
   | Const_block of int * structured_constant list
+  | Const_pointer of int
 
 type lambda =
     Lvar of Ident.t
   | Lapply of lambda * lambda list
   | Lfunction of Ident.t * lambda
   | Llet of Ident.t * lambda * lambda
-  | Lletrec of (Ident.t * lambda * int) list * lambda
+  | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list
   | Lswitch of lambda * int * (int * lambda) list * int * (int * lambda) list
   | Lstaticfail
     Lvar id -> fn id
   | _ -> let id = Ident.new "let" in Llet(id, arg, fn id)
 
+let name_lambda_list args fn =
+  let rec name_list names = function
+    [] -> fn (List.rev names)
+  | (Lvar id as arg) :: rem ->
+      name_list (arg :: names) rem
+  | arg :: rem ->
+      let id = Ident.new "let" in
+      Llet(id, arg, name_list (Lvar id :: names) rem) in
+  name_list [] args
+
 module IdentSet =
   Set.Make(struct
     type t = Ident.t
       freevars arg; freevars body; fv := IdentSet.remove id !fv
   | Lletrec(decl, body) ->
       freevars body;
-      List.iter (fun (id, exp, sz) -> freevars exp) decl;
-      List.iter (fun (id, exp, sz) -> fv := IdentSet.remove id !fv) decl
+      List.iter (fun (id, exp) -> freevars exp) decl;
+      List.iter (fun (id, exp) -> fv := IdentSet.remove id !fv) decl
   | Lprim(p, args) ->
       List.iter freevars args
   | Lswitch(arg, num_cases1, cases1, num_cases2, cases2) ->
       freevars e1; freevars e2; freevars e3; fv := IdentSet.remove v !fv
   | Lshared(e, lblref) ->
       freevars e
-  in freevars l; IdentSet.elements !fv
+  in freevars l; !fv
 
 (* Check if an action has a "when" guard *)
 

bytecomp/lambda.mli

 type structured_constant =
     Const_base of constant
   | Const_block of int * structured_constant list
+  | Const_pointer of int
 
 type lambda =
     Lvar of Ident.t
   | Lapply of lambda * lambda list
   | Lfunction of Ident.t * lambda
   | Llet of Ident.t * lambda * lambda
-  | Lletrec of (Ident.t * lambda * int) list * lambda
+  | Lletrec of (Ident.t * lambda) list * lambda
   | Lprim of primitive * lambda list
   | Lswitch of lambda * int * (int * lambda) list * int * (int * lambda) list
   | Lstaticfail
 val lambda_unit: lambda
 val share_lambda: lambda -> lambda
 val name_lambda: lambda -> (Ident.t -> lambda) -> lambda
-val free_variables: lambda -> Ident.t list
+val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
 val is_guarded: lambda -> bool
 
+module IdentSet: Set.S with elt = Ident.t
+val free_variables: lambda -> IdentSet.t
+
 type compilenv
 
 val empty_env: compilenv

bytecomp/matching.ml

 (* Compilation of pattern matching *)
 
+open Misc
 open Location
 open Asttypes
 open Typedtree
 
 (* Matching against a tuple pattern *)
 
-let make_tuple_matching num_comps (arg :: argl) =
-  let rec make_args pos =
-    if pos >= num_comps
-    then argl
-    else Lprim(Pfield pos, [arg]) :: make_args (pos + 1) in
-  {cases = []; args = make_args 0}
+let make_tuple_matching num_comps = function
+    [] -> fatal_error "Matching.make_tuple_matching"
+  | Lprim(Pmakeblock _, components) :: argl ->
+      {cases = []; args = components @ argl}
+  | arg :: argl ->
+      let rec make_args pos =
+        if pos >= num_comps
+        then argl
+        else Lprim(Pfield pos, [arg]) :: make_args (pos + 1) in
+      {cases = []; args = make_args 0}
 
 let any_pat =
   {pat_desc = Tpat_any; pat_loc = Location.none; pat_type = Ctype.none}
                Const_base(Const_int loc.loc_end)]))])])
 
 let for_function loc param pat_act_list =
-  compile_matching (partial_function loc) (Lvar param) pat_act_list
+  compile_matching (partial_function loc) param pat_act_list
 
 let for_trywith param pat_act_list =
   compile_matching (fun () -> Lprim(Praise, [Lvar param]))

bytecomp/matching.mli

 open Lambda
 
 val for_function:
-        Location.t -> Ident.t -> (pattern * lambda) list -> lambda
+        Location.t -> lambda -> (pattern * lambda) list -> lambda
 val for_trywith:
         Ident.t -> (pattern * lambda) list -> lambda
 val for_let:

bytecomp/printlambda.ml

       print_string "\""; print_string(String.escaped s); print_string "\""
   | Const_base(Const_float s) ->
       print_string s
+  | Const_pointer n -> print_int n; print_string "a"
   | Const_block(tag, []) ->
       print_string "["; print_int tag; print_string "]"
   | Const_block(tag, sc1::scl) ->
     Pidentity -> print_string "id"
   | Pgetglobal id -> print_string "global "; Ident.print id
   | Psetglobal id -> print_string "setglobal "; Ident.print id
-  | Pmakeblock sz -> print_string "makeblock "; print_int sz
+  | Pmakeblock tag -> print_string "makeblock "; print_int tag
   | Pfield n -> print_string "field "; print_int n
   | Psetfield n -> print_string "setfield "; print_int n
   | Pccall(name, arity) -> print_string name
       print_string "(";
       let spc = ref false in
       List.iter
-        (fun (id, l, sz) ->
+        (fun (id, l) ->
           if !spc then print_space() else spc := true;
           Ident.print id; print_string " "; lambda l)
         id_arg_list;

bytecomp/symtable.ml

   | Const_base(Const_char c) -> Obj.repr c
   | Const_base(Const_string s) -> Obj.repr s
   | Const_base(Const_float f) -> Obj.repr(float_of_string f)
+  | Const_pointer i -> Obj.repr i
   | Const_block(tag, fields) ->
       let block = Obj.new_block tag (List.length fields) in
       let pos = ref 0 in

bytecomp/translcore.ml

 
 (* Compute the access paths to identifiers bound in patterns. *)
 
+let identity_env e = e
+
 let rec bind_pattern env pat arg mut =
   match pat.pat_desc with
     Tpat_var id ->
       begin match mut with
         Mutable   -> (env, fun e -> Llet(id, arg, e))
-      | Immutable -> (add_env id arg env, fun e -> e)
+      | Immutable -> (add_env id arg env, identity_env)
       end
   | Tpat_alias(pat, id) ->
       let (ext_env, bind) = bind_pattern env pat arg mut in
       | Immutable -> (add_env id arg ext_env, bind)
       end
   | Tpat_tuple patl ->
-      bind_pattern_list env patl arg mut 0
+      begin match arg with
+        Lprim(Pmakeblock _, argl) -> bind_patterns env patl argl
+      | _ -> bind_pattern_list env patl arg mut 0
+      end
   | Tpat_construct(cstr, patl) ->
       begin match cstr.cstr_tag with
-        Cstr_constant _  -> (env, fun e -> e)
+        Cstr_constant _  -> (env, identity_env)
       | Cstr_block _     -> bind_pattern_list env patl arg mut 0
       | Cstr_exception _ -> bind_pattern_list env patl arg mut 1
       end
   | Tpat_record lbl_pat_list ->
       bind_label_pattern env lbl_pat_list arg mut
   | _ ->
-      (env, fun e -> e)
+      (env, identity_env)
 
 and bind_pattern_list env patl arg mut pos =
   match patl with
-    [] -> (env, fun e -> e)
+    [] -> (env, identity_env)
   | pat :: rem ->
       let (env1, bind1) =
         bind_pattern env pat (Lprim(Pfield pos, [arg])) mut in
 
 and bind_label_pattern env patl arg mut =
   match patl with
-    [] -> (env, fun e -> e)
+    [] -> (env, identity_env)
   | (lbl, pat) :: rem ->
       let mut1 =
         match lbl.lbl_mut with Mutable -> Mutable | Immutable -> mut in
         bind_label_pattern env1 rem arg mut in
       (env2, fun e -> bind1(bind2 e))
 
+and bind_patterns env patl argl =
+  match (patl, argl) with
+    ([], []) -> (env, identity_env)
+  | (pat1::patl, arg1::argl) ->
+      let (env1, bind1) = bind_pattern env pat1 arg1 Immutable in
+      let (env2, bind2) = bind_patterns env1 patl argl in
+      (env2, fun e -> bind1(bind2 e))
+  | (_, _) ->
+      fatal_error "Translcore.bind_patterns"
+
 (* Translation of primitives *)
 
 let comparisons_table = create_hashtable 11 [
   "%geint", Pintcomp Cge;
   "%incr", Poffsetref(1);
   "%decr", Poffsetref(-1);
+  "%negfloat", Pnegfloat;
   "%addfloat", Paddfloat;
   "%subfloat", Psubfloat;
   "%mulfloat", Pmulfloat;
   with Not_found ->
     Pccall(prim, arity)
 
-(* To compile "let rec" *)
+(* To check the well-formedness of r.h.s. of "let rec" definitions *)
 
-exception Unknown
-
-let size_of_lambda id lam =
-  let rec size = function
-      Lfunction(param, body) as funct -> 1 + List.length(free_variables funct)
-    | Lprim(Pmakeblock tag, args) -> List.iter check args; List.length args
-    | Llet(id, arg, body) -> check arg; size body
-    | _ -> raise Unknown
+let check_recursive_lambda id lam =
+  let rec check_top = function
+      Lfunction(param, body) as funct -> true
+    | Lprim(Pmakeblock tag, args) -> List.for_all check args
+    | Llet(id, arg, body) -> check arg & check_top body
+    | _ -> false
   and check = function
-      Lvar _ -> ()
-    | Lconst cst -> ()
-    | Lfunction(param, body) -> ()
-    | Llet(_, arg, body) -> check arg; check body
-    | Lprim(Pmakeblock tag, args) -> List.iter check args
-    | lam -> if List.mem id (free_variables lam) then raise Unknown
-  in size lam
+      Lvar _ -> true
+    | Lconst cst -> true
+    | Lfunction(param, body) -> true
+    | Llet(_, arg, body) -> check arg & check body
+    | Lprim(Pmakeblock tag, args) -> List.for_all check args
+    | lam -> not(IdentSet.mem id (free_variables lam))
+  in check_top lam
 
 (* To propagate structured constants *)
 
 
 let extract_constant = function Lconst sc -> sc | _ -> raise Not_constant
 
+(* To find reasonable names for let-bound and lambda-bound idents *)
+
+let name_pattern default p =
+  match p.pat_desc with
+    Tpat_var id -> id
+  | Tpat_alias(p, id) -> id
+  | _ -> Ident.new default
+
+let name_pattern_list default = function
+    [] -> Ident.new default
+  | (p, e) :: _ -> name_pattern default p
+
 (* Translation of expressions *)
 
 let rec transl_exp env e =
       let (ext_env, add_let) = transl_let env rec_flag pat_expr_list in
       add_let(transl_exp ext_env body)
   | Texp_function pat_expr_list ->
-      let param = Ident.new "fun" in
-      Lfunction(param, Matching.for_function e.exp_loc param
-                         (transl_cases env param pat_expr_list))
+      let param = name_pattern_list "param" pat_expr_list in
+      Lfunction(param, Matching.for_function e.exp_loc (Lvar param)
+                         (transl_cases env (Lvar param) pat_expr_list))
   | Texp_apply({exp_desc = Texp_ident(path, {val_prim = Primitive(s, arity)})},
                args) when List.length args = arity ->
       Lprim(transl_prim s arity args, transl_list env args)
   | Texp_apply(funct, args) ->
       Lapply(transl_exp env funct, transl_list env args)
+  | Texp_match({exp_desc = Texp_tuple argl} as arg, pat_expr_list) ->
+      name_lambda_list (transl_list env argl) (fun paraml ->
+        let param = Lprim(Pmakeblock 0, paraml) in
+          Matching.for_function e.exp_loc param
+              (transl_cases env param pat_expr_list))
   | Texp_match(arg, pat_expr_list) ->
-      name_lambda (transl_exp env arg)
-        (fun id ->
-          Matching.for_function e.exp_loc id
-                                 (transl_cases env id pat_expr_list))
+      name_lambda (transl_exp env arg) (fun id ->
+        Matching.for_function e.exp_loc (Lvar id)
+                              (transl_cases env (Lvar id) pat_expr_list))
   | Texp_try(body, pat_expr_list) ->
       let id = Ident.new "exn" in
       Ltrywith(transl_exp env body, id,
-               Matching.for_trywith id (transl_cases env id pat_expr_list))
+               Matching.for_trywith id
+                 (transl_cases env (Lvar id) pat_expr_list))
   | Texp_tuple el ->
       let ll = transl_list env el in
       begin try
       let ll = transl_list env args in
       begin match cstr.cstr_tag with
         Cstr_constant n ->
-          Lconst(Const_base(Const_int n))
+          Lconst(Const_pointer n)
       | Cstr_block n ->
           begin try
             Lconst(Const_block(n, List.map extract_constant ll))
 
 and transl_cases env param pat_expr_list =
   let transl_case (pat, expr) =
-    let (ext_env, bind_fun) = bind_pattern env pat (Lvar param) Immutable in
+    let (ext_env, bind_fun) = bind_pattern env pat param Immutable in
     (pat, bind_fun(transl_exp ext_env expr)) in
   List.map transl_case pat_expr_list
 
     Nonrecursive ->
       let rec transl body_env = function
         [] ->
-          (body_env, fun e -> e)
+          (body_env, identity_env)
       | (pat, expr) :: rem ->
-          let id = Ident.new "let" in
+          let id = name_pattern "let" pat in
           let (ext_env, bind_fun) =
             bind_pattern body_env pat (Lvar id) Immutable in
           let (final_env, add_let_fun) =
             Tpat_var id -> id
           | _ -> raise(Error(pat.pat_loc, Illegal_letrec_pat)) in
         let lam = transl_exp env expr in
-        let size =
-          try size_of_lambda id lam
-          with Unknown -> raise(Error(expr.exp_loc, Illegal_letrec_expr)) in
-        (id, lam, size) in
+        if not (check_recursive_lambda id lam) then
+          raise(Error(expr.exp_loc, Illegal_letrec_expr));
+        (id, lam) in
       let decls =
         List.map transl_case pat_expr_list in
       (env, fun e -> Lletrec(decls, e))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.