Commits

Anonymous committed 7c0ef11

Changement representation des constructeurs constants.

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

  • Participants
  • Parent commits 5c5917d

Comments (0)

Files changed (26)

File bytecomp/codegen.ml

 open Lambda
 open Instruct
 
-
 (**** Label generation ****)
 
 let label_counter = ref 0
           Pgetglobal id -> Kgetglobal id
         | Psetglobal id -> Ksetglobal id
         | Pupdate -> Kupdate
-        | Pcomp cmp -> Kintcomp cmp
+        | Pintcomp cmp -> Kintcomp cmp
         | Pmakeblock tag -> Kmakeblock(List.length args, tag)
-        | Ptagof -> Ktagof
         | Pfield n -> Kgetfield n
         | Psetfield n -> Ksetfield n
         | Pccall(name, n) -> Kccall(name, n)
         | 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) ->
       Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
         comp_expr env body sz
           (Klabel lbl_test ::
-            comp_expr env cond sz (Kbranchif lbl_loop :: cont))
+            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
               Kacc 0 :: Kpush :: Kacc 2 :: Kintcomp comp ::
               Kbranchif lbl_loop ::
               add_const_unit (add_pop 2 cont))))
-  | Lswitch(arg, lo, hi, casel) ->
-      let numcases = List.length casel in
-      let cont1 =
-        if lo = 0 & numcases >= hi - 8 then (* Always true if hi <= 8... *)
-          comp_direct_switch env hi casel sz cont
-        else begin
-          let (transl_table, actions) = Dectree.make_decision_tree casel in
-          Ktranslate transl_table :: comp_switch env actions sz cont 
-        end in
-      comp_expr env arg sz cont1
+  | 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 ->
     end in
   comp_expr env cond sz cont_cond
 
-(* Compile a Lswitch directly, without breaking the array of cases into
-   dense enough components *)
-
-and comp_direct_switch env range casel sz cont =
-  let actv = Array.new range Lstaticfail in
-  List.iter (fun (n, act) -> actv.(n) <- act) casel;
-  comp_switch env actv sz cont
-
-(* Compile a switch instruction *)
-
-and comp_switch env actv sz cont =
-  (* To ensure stack balancing, we must have either sz = !sz_staticfail
-     or none of the actv.(i) contains an unguarded Lstaticfail. *)
-  let lblv = Array.new (Array.length actv) !lbl_staticfail in
-  let (branch, cont1) = make_branch cont in
-  let c = ref (discard_dead_code cont1) in
-  for i = Array.length actv - 1 downto 0 do
-    let (lbl, c1) = label_code(comp_expr env actv.(i) sz (branch :: !c)) in
-    lblv.(i) <- lbl;
-    c := discard_dead_code c1
-  done;
-  Kswitch lblv :: !c
-
 (**** Compilation of functions ****)
 
 let comp_function (param, body, entry_lbl, free_vars) cont =

File bytecomp/dectree.ml

     (* Record the segment and continue *)
     (start, !stop) :: partition (!stop + 1) in
   let part = partition 0 in
-  (* Compute the length of the switch table.
-     Slot 0 is reserved and always contains Lstaticfail. *)
-  let switchl = ref 1 in
-  List.iter
-    (fun (start, stop) -> switchl := !switchl + keyv.(stop) - keyv.(start) + 1)
-    part;
   (* Build the two tables *)
   let transl = Array.new (List.length part) (0, 0, 0)
-  and switch = Array.new !switchl Lstaticfail in
+  and switch = ref [] in
   let tr_pos = ref 0
-  and sw_ind = ref 1 in
+  and sw_ind = ref 1 in (* Slot 0 in switch is reserved for Lstaticfail *)
   List.iter
     (fun (start, stop) ->
       transl.(!tr_pos) <- (keyv.(start), keyv.(stop), !sw_ind);
       for i = start to stop do
-        switch.(!sw_ind + keyv.(i) - keyv.(start)) <- actv.(i)
+        switch := (!sw_ind + keyv.(i) - keyv.(start), actv.(i)) :: !switch
       done;
       incr tr_pos;
       sw_ind := !sw_ind + keyv.(stop) - keyv.(start) + 1)
     part;
-  (transl, switch)
+  (transl, !switch, !sw_ind)

File bytecomp/dectree.mli

 open Lambda
 
 (* Input: a list of (key, action) pairs, where keys are integers. *)
-(* Output: a table of (low, high, offset) triples for Ktranslate
-           an array of actions for Kswitch *)
+(* Output: a table of (low, high, offset) triples for Ptranslate
+           a list of actions for Lswitch *)
 
 val make_decision_tree:
-  (int * lambda) list -> (int * int * int) array * lambda array
+  (int * lambda) list -> (int * int * int) array * (int * lambda) list * int

File bytecomp/emitcode.ml

     cu_interfaces: (string * int) list } (* Names and CRC of intfs imported *)
 
 (* Format of a .cmo file:
-     Obj.magic number (Config.cmo_magic_number)
+     magic number (Config.cmo_magic_number)
      absolute offset of compilation unit descriptor
      block of relocatable bytecode
      compilation unit descriptor *)
   | Kconst sc ->
       begin match sc with
         Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
-          out opCONSTINT; out_int i
+          if i >= 0 & i <= 3
+          then out (opCONST0 + i)
+          else (out opCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opCONSTINT; out_int (Char.code c)
       | Const_block(t, []) ->
-          if t < 4 then out (opATOM0 + t) else (out opATOM; out_int t)
+          if t = 0 then out opATOM0 else (out opATOM; out_int t)
       | _ ->
           out opGETGLOBAL; slot_for_literal sc
       end
       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)
-  | Ktagof -> out opTAGOF
   | Kdummy n -> out opDUMMY; out_int n
   | Kupdate -> out opUPDATE
   | Kvectlength -> out opVECTLENGTH
   | Kbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
   | Kstrictbranchif lbl -> out opBRANCHIF; out_label lbl
   | Kstrictbranchifnot lbl -> out opBRANCHIFNOT; out_label lbl
-  | Kswitch lblv ->
-      out opSWITCH; out_int (Array.length lblv);
+  | Kswitch(tbl_const, tbl_block) ->
+      out opSWITCH;
+      out_int (Array.length tbl_const + (Array.length tbl_block lsl 16));
       let org = !out_position in
-      Array.iter (out_label_with_orig org) lblv
+      Array.iter (out_label_with_orig org) tbl_const;
+      Array.iter (out_label_with_orig org) tbl_block
   | Ktranslate tbl ->
       out opTRANSLATE; out_int (Array.length tbl);
       Array.iter
   | Kpush :: Kconst sc :: c ->
       begin match sc with
         Const_base(Const_int i) when i >= immed_min & i <= immed_max ->
-          out opPUSHCONSTINT; out_int i
+          if i >= 0 & i <= 3
+          then out (opPUSHCONST0 + i)
+          else (out opPUSHCONSTINT; out_int i)
       | Const_base(Const_char c) ->
           out opPUSHCONSTINT; out_int(Char.code c)
       | Const_block(t, []) ->
-          if t < 4 then out (opPUSHATOM0 + t) else (out opPUSHATOM; out_int t)
+          if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t)
       | _ ->
           out opPUSHGETGLOBAL; slot_for_literal sc
       end;

File bytecomp/instruct.ml

   | Kmakeblock of int * int             (* size, tag *)
   | Kgetfield of int
   | Ksetfield of int
-  | Ktagof
   | Kdummy of int
   | Kupdate
   | Kvectlength
   | Kbranchifnot of label
   | Kstrictbranchif of label
   | Kstrictbranchifnot of label
-  | Kswitch of label array
+  | Kswitch of label array * label array
   | Ktranslate of (int * int * int) array
   | Kboolnot
   | Kpushtrap of label

File bytecomp/instruct.mli

   | Kmakeblock of int * int             (* size, tag *)
   | Kgetfield of int
   | Ksetfield of int
-  | Ktagof
   | Kdummy of int
   | Kupdate
   | Kvectlength
   | Kbranchifnot of label
   | Kstrictbranchif of label
   | Kstrictbranchifnot of label
-  | Kswitch of label array
+  | Kswitch of label array * label array
   | Ktranslate of (int * int * int) array
   | Kboolnot
   | Kpushtrap of label

File bytecomp/lambda.ml

   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
   | Pmakeblock of int
-  | Ptagof
   | Pfield of int
   | Psetfield of int
   | Pccall of string * int
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
-  | Pcomp of comparison
+  | Pintcomp of comparison
   | Poffsetint of int
   | Poffsetref of int
+  | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of comparison
   | Pgetstringchar | Psetstringchar
   | Pvectlength | Pgetvectitem | Psetvectitem
+  | Ptranslate of (int * int * int) array
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge
   | Llet of Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda * int) list * lambda
   | Lprim of primitive * lambda list
-  | Lswitch of lambda * int * int * (int * lambda) list
+  | Lswitch of lambda * int * (int * lambda) list * int * (int * lambda) list
   | Lstaticfail
   | Lcatch of lambda * lambda
   | Ltrywith of lambda * Ident.t * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lshared of lambda * int option ref
 
-let const_unit = Const_block(0, [])
+let const_unit = Const_base(Const_int 0)
 
 let lambda_unit = Lconst const_unit
 
       List.iter (fun (id, exp, sz) -> fv := IdentSet.remove id !fv) decl
   | Lprim(p, args) ->
       List.iter freevars args
-  | Lswitch(arg, lo, hi, cases) ->
-      freevars arg; List.iter (fun (key, case) -> freevars case) cases
+  | Lswitch(arg, num_cases1, cases1, num_cases2, cases2) ->
+      freevars arg; 
+      List.iter (fun (key, case) -> freevars case) cases1;
+      List.iter (fun (key, case) -> freevars case) cases2
   | Lstaticfail -> ()
   | Lcatch(e1, e2) ->
       freevars e1; freevars e2

File bytecomp/lambda.mli

   | Pgetglobal of Ident.t
   | Psetglobal of Ident.t
   | Pmakeblock of int
-  | Ptagof
   | Pfield of int
   | Psetfield of int
   | Pccall of string * int
   | Pnegint | Paddint | Psubint | Pmulint | Pdivint | Pmodint
   | Pandint | Porint | Pxorint
   | Plslint | Plsrint | Pasrint
-  | Pcomp of comparison
+  | Pintcomp of comparison
   | Poffsetint of int
   | Poffsetref of int
+  | Pnegfloat | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of comparison
   | Pgetstringchar | Psetstringchar
   | Pvectlength | Pgetvectitem | Psetvectitem
+  | Ptranslate of (int * int * int) array
 
 and comparison =
     Ceq | Cneq | Clt | Cgt | Cle | Cge
   | Llet of Ident.t * lambda * lambda
   | Lletrec of (Ident.t * lambda * int) list * lambda
   | Lprim of primitive * lambda list
-  | Lswitch of lambda * int * int * (int * lambda) list
+  | Lswitch of lambda * int * (int * lambda) list * int * (int * lambda) list
   | Lstaticfail
   | Lcatch of lambda * lambda
   | Ltrywith of lambda * Ident.t * lambda

File bytecomp/matching.ml

 let make_constr_matching cstr (arg :: argl) =
   let (first_pos, last_pos) =
     match cstr.cstr_tag with
-      Cstr_tag _ -> (0, cstr.cstr_arity - 1)
+      Cstr_constant _ | Cstr_block _ -> (0, cstr.cstr_arity - 1)
     | Cstr_exception _ -> (1, cstr.cstr_arity) in
   let rec make_args pos =
     if pos > last_pos
 let combine_var (lambda1, total1) (lambda2, total2) =
   if total1 then (lambda1, true) else (Lcatch(lambda1, lambda2), total2)
 
+let make_test_sequence tst arg const_lambda_list =
+  List.fold_right
+    (fun (c, act) rem ->
+      Lifthenelse(Lprim(tst, [arg; Lconst(Const_base c)]), act, rem))
+    const_lambda_list Lstaticfail
+
 let combine_constant arg cst (const_lambda_list, total1) (lambda2, total2) =
   let lambda1 =
     match cst with
       Const_int _ ->
-        List.fold_right
-          (fun (c, act) rem ->
-            Lifthenelse(
-              Lprim(Pcomp Ceq, [arg; Lconst(Const_base c)]), act, rem))
-          const_lambda_list Lstaticfail
+        make_test_sequence (Pintcomp Ceq) arg const_lambda_list
     | Const_char _ ->
-        Lswitch(arg, 0, 256,
-                List.map (fun (Const_char c, l) -> (Char.code c, l))
-                    const_lambda_list)
-    | Const_string _ | Const_float _ ->
-        List.fold_right
-          (fun (c, act) rem ->
-            Lifthenelse(
-              Lprim(Pccall("equal", 2), [arg; Lconst(Const_base c)]),
-              act, rem))
-          const_lambda_list Lstaticfail
+        let casel =
+          List.map (fun (Const_char c, l) -> (Char.code c, l))
+                   const_lambda_list in
+        let (transl_table, actions, num_actions) =
+          Dectree.make_decision_tree casel in
+        Lswitch(Lprim(Ptranslate transl_table, [arg]),
+                num_actions, actions, 0, [])
+    | Const_string _ ->
+        make_test_sequence (Pccall("equal", 2)) arg const_lambda_list
+    | Const_float _ ->
+        make_test_sequence (Pfloatcomp Ceq) arg const_lambda_list
   in (Lcatch(lambda1, lambda2), total2)
 
 let combine_constructor arg cstr (tag_lambda_list, total1) (lambda2, total2) =
-  if cstr.cstr_span < 0 then begin
+  if cstr.cstr_consts < 0 then begin
     (* Special cases for exceptions *)
     let lambda1 =
       List.fold_right
         (fun (Cstr_exception path, act) rem ->
-          Lifthenelse(Lprim(Pcomp Ceq, [Lprim(Pfield 0, [arg]);
-                                        transl_path path]), act, rem))
+          Lifthenelse(Lprim(Pintcomp Ceq, 
+                            [Lprim(Pfield 0, [arg]); transl_path path]),
+                      act, rem))
         tag_lambda_list Lstaticfail
     in (Lcatch(lambda1, lambda2), total2)
   end else begin
     (* Regular concrete type *)
-    let caselist =
-      List.map (function (Cstr_tag n, act) -> (n, act)) tag_lambda_list in
+    let rec split_cases = function
+      [] -> ([], [])
+    | (cstr, act) :: rem ->
+        let (consts, nonconsts) = split_cases rem in
+        match cstr with
+          Cstr_constant n -> ((n, act) :: consts, nonconsts)
+        | Cstr_block n    -> (consts, (n, act) :: nonconsts) in
+    let (consts, nonconsts) = split_cases tag_lambda_list in
     let lambda1 =
-      match (caselist, cstr.cstr_span) with
-        ([0, act], 1) -> act
-      | ([0, act], 2) -> Lifthenelse(arg, Lstaticfail, act)
-      | ([1, act], 2) -> Lifthenelse(arg, act, Lstaticfail)
-      | ([0, act0; 1, act1], 2) -> Lifthenelse(arg, act1, act0)
-      | ([1, act1; 0, act0], 2) -> Lifthenelse(arg, act1, act0)
-      | _ ->
-          if cstr.cstr_span < Config.max_tag
-          then Lswitch(Lprim(Ptagof, [arg]), 0, cstr.cstr_span, caselist)
-          else Lswitch(Lprim(Pfield 0, [arg]), 0, cstr.cstr_span, caselist) in
-    if total1 & List.length tag_lambda_list = cstr.cstr_span
+      match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with
+        (1, 0, [0, act], []) -> act
+      | (0, 1, [], [0, act]) -> act
+      | (1, 1, [0, act1], [0, act2]) ->
+          Lifthenelse(arg, act2, act1)
+      | (1, 1, [0, act1], []) ->
+          Lifthenelse(arg, Lstaticfail, act1)
+      | (1, 1, [], [0, act2]) ->
+          Lifthenelse(arg, act2, Lstaticfail)
+      | (_, _, _, _) ->
+          Lswitch(arg, cstr.cstr_consts, consts,
+                       cstr.cstr_nonconsts, nonconsts) in
+    if total1
+     & List.length tag_lambda_list = cstr.cstr_consts + cstr.cstr_nonconsts
     then (lambda1, true)
     else (Lcatch(lambda1, lambda2), total2)
   end

File bytecomp/printinstr.ml

       print_string "\tmakeblock "; print_int n; print_string ", "; print_int m
   | Kgetfield n -> print_string "\tgetfield "; print_int n
   | Ksetfield n -> print_string "\tsetfield "; print_int n
-  | Ktagof -> print_string "\ttagof"
   | Kdummy n -> print_string "\tdummy "; print_int n
   | Kupdate -> print_string "\tupdate"
   | Kvectlength -> print_string "\tvectlength"
   | Kstrictbranchif lbl -> print_string "\tstrictbranchif L"; print_int lbl
   | Kstrictbranchifnot lbl ->
       print_string "\tstrictbranchifnot L"; print_int lbl
-  | Kswitch lblv ->
+  | Kswitch(consts, blocks) ->
       open_hovbox 10;
       print_string "\tswitch";
-      Array.iter (fun lbl -> print_space(); print_int lbl) lblv;
+      Array.iter (fun lbl -> print_space(); print_int lbl) consts;
+      print_string "/";
+      Array.iter (fun lbl -> print_space(); print_int lbl) blocks;
       close_box()
   | Ktranslate tbl ->
       open_hovbox 10;

File bytecomp/printlambda.ml

   | Pgetglobal id -> print_string "global "; Ident.print id
   | Psetglobal id -> print_string "setglobal "; Ident.print id
   | Pmakeblock sz -> print_string "makeblock "; print_int sz
-  | Ptagof -> print_string "tag"
   | Pfield n -> print_string "field "; print_int n
   | Psetfield n -> print_string "setfield "; print_int n
   | Pccall(name, arity) -> print_string name
   | Plslint -> print_string "lsl"
   | Plsrint -> print_string "lsr"
   | Pasrint -> print_string "asr"
-  | Pcomp(Ceq) -> print_string "=="
-  | Pcomp(Cneq) -> print_string "!="
-  | Pcomp(Clt) -> print_string "<"
-  | Pcomp(Cle) -> print_string "<="
-  | Pcomp(Cgt) -> print_string ">"
-  | Pcomp(Cge) -> print_string ">="
+  | Pintcomp(Ceq) -> print_string "=="
+  | Pintcomp(Cneq) -> print_string "!="
+  | Pintcomp(Clt) -> print_string "<"
+  | Pintcomp(Cle) -> print_string "<="
+  | Pintcomp(Cgt) -> print_string ">"
+  | Pintcomp(Cge) -> print_string ">="
   | Poffsetint n -> print_int n; print_string "+"
   | Poffsetref n -> print_int n; print_string "+:="
+  | Pnegfloat -> print_string "~."
+  | Paddfloat -> print_string "+."
+  | Psubfloat -> print_string "-."
+  | Pmulfloat -> print_string "*."
+  | Pdivfloat -> print_string "/."
+  | Pfloatcomp(Ceq) -> print_string "==."
+  | Pfloatcomp(Cneq) -> print_string "!=."
+  | Pfloatcomp(Clt) -> print_string "<."
+  | Pfloatcomp(Cle) -> print_string "<=."
+  | Pfloatcomp(Cgt) -> print_string ">."
+  | Pfloatcomp(Cge) -> print_string ">=."
   | Pgetstringchar -> print_string "string.get"
   | Psetstringchar -> print_string "string.set"
   | Pvectlength -> print_string "array.length"
   | Pgetvectitem -> print_string "array.get"
   | Psetvectitem -> print_string "array.set"
+  | Ptranslate tbl ->
+      print_string "translate [";
+      open_hvbox 0;
+      for i = 0 to Array.length tbl - 1 do
+        if i > 0 then print_space();
+        let (lo, hi, ofs) = tbl.(i) in
+        print_space(); print_int lo; print_string "/";
+        print_int hi; print_string "/"; print_int ofs
+      done;
+      print_string "]"; close_box()
 
 let rec lambda = function
     Lvar id ->
       List.iter (fun l -> print_space(); lambda l) largs;
       print_string ")";
       close_box()
-  | Lswitch(larg, lo, hi, cases) ->
+  | Lswitch(larg, num_cases1, cases1, num_cases2, cases2) ->
       open_hovbox 1;
-      print_string "(switch "; print_int lo; print_string "/";
-      print_int hi; print_space();
-      lambda larg; print_space();
+      print_string "(switch "; lambda larg; print_space();
       open_vbox 0;
       let spc = ref false in
       List.iter
         (fun (n, l) ->
+          if !spc then print_space() else spc := true;
+          open_hvbox 1;
+          print_string "case int "; print_int n;
+          print_string ":"; print_space();
+          lambda l;
+          close_box())
+        cases1;
+      List.iter
+        (fun (n, l) ->
+          if !spc then print_space() else spc := true;
           open_hvbox 1;
-          print_string "case "; print_int n; print_string ":"; print_space();
+          print_string "case tag "; print_int n;
+          print_string ":"; print_space();
           lambda l;
-          close_box();
-          if !spc then print_space() else spc := true)
-        cases;
+          close_box())
+        cases2;
       print_string ")"; close_box(); close_box()
   | Lstaticfail ->
       print_string "exit"

File bytecomp/translcore.ml

   | Tpat_tuple patl ->
       bind_pattern_list env patl arg mut 0
   | Tpat_construct(cstr, patl) ->
-      bind_pattern_list env patl arg mut
-        (match cstr.cstr_tag with
-            Cstr_tag _ -> 0
-          | Cstr_exception _ -> 1)
+      begin match cstr.cstr_tag with
+        Cstr_constant _  -> (env, fun e -> e)
+      | 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
   | _ ->
 
 let comparisons_table = create_hashtable 11 [
   "%equal",
-      (Pccall("equal", 2), Pcomp Ceq, Pccall("eq_float", 2));
+      (Pccall("equal", 2), Pintcomp Ceq, Pfloatcomp Ceq);
   "%notequal",
-      (Pccall("notequal", 2), Pcomp Cneq, Pccall("neq_float", 2));
+      (Pccall("notequal", 2), Pintcomp Cneq, Pfloatcomp Cneq);
   "%lessthan",
-      (Pccall("lessthan", 2), Pcomp Clt, Pccall("lt_float", 2));
+      (Pccall("lessthan", 2), Pintcomp Clt, Pfloatcomp Clt);
   "%greaterthan",
-      (Pccall("greaterthan", 2), Pcomp Cgt, Pccall("gt_float", 2));
+      (Pccall("greaterthan", 2), Pintcomp Cgt, Pfloatcomp Cgt);
   "%lessequal",
-      (Pccall("lessequal", 2), Pcomp Cle, Pccall("le_float", 2));
+      (Pccall("lessequal", 2), Pintcomp Cle, Pfloatcomp Cle);
   "%greaterequal",
-      (Pccall("greaterequal", 2), Pcomp Cge, Pccall("ge_float", 2))
+      (Pccall("greaterequal", 2), Pintcomp Cge, Pfloatcomp Cge)
 ]
 
 let primitives_table = create_hashtable 31 [
   "%identity", Pidentity;
-  "%tagof", Ptagof;
   "%field0", Pfield 0;
   "%field1", Pfield 1;
   "%setfield0", Psetfield 0;
   "%lslint", Plslint;
   "%lsrint", Plsrint;
   "%asrint", Pasrint;
-  "%eq", Pcomp Ceq;
-  "%noteq", Pcomp Cneq;
-  "%ltint", Pcomp Clt;
-  "%leint", Pcomp Cle;
-  "%gtint", Pcomp Cgt;
-  "%geint", Pcomp Cge;
+  "%eq", Pintcomp Ceq;
+  "%noteq", Pintcomp Cneq;
+  "%ltint", Pintcomp Clt;
+  "%leint", Pintcomp Cle;
+  "%gtint", Pintcomp Cgt;
+  "%geint", Pintcomp Cge;
   "%incr", Poffsetref(1);
   "%decr", Poffsetref(-1);
+  "%addfloat", Paddfloat;
+  "%subfloat", Psubfloat;
+  "%mulfloat", Pmulfloat;
+  "%divfloat", Pdivfloat;
+  "%eqfloat", Pfloatcomp Ceq;
+  "%noteqfloat", Pfloatcomp Cneq;
+  "%ltfloat", Pfloatcomp Clt;
+  "%lefloat", Pfloatcomp Cle;
+  "%gtfloat", Pfloatcomp Cgt;
+  "%gefloat", Pfloatcomp Cge;
   "%string_unsafe_get", Pgetstringchar;
   "%string_unsafe_set", Psetstringchar;
   "%array_length", Pvectlength;
   | Texp_construct(cstr, args) ->
       let ll = transl_list env args in
       begin match cstr.cstr_tag with
-        Cstr_tag n ->
+        Cstr_constant n ->
+          Lconst(Const_base(Const_int n))
+      | Cstr_block n ->
           begin try
             Lconst(Const_block(n, List.map extract_constant ll))
           with Not_constant ->
         (fun (lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp env expr)
         lbl_expr_list;
       let ll = Array.to_list lv in
-      if List.for_all (fun (lbl, expr) -> lbl.lbl_mut = Immutable) lbl_expr_list
+      if List.for_all (fun (lbl, expr) -> lbl.lbl_mut = Immutable)
+                      lbl_expr_list
       then begin
         try
           Lconst(Const_block(0, List.map extract_constant ll))

File byterun/alloc.c

 {
   int res;
   res = 0;
-  while (Tag_val(list) == 1) {
-    res |= flags[Tag_val(Field(list, 0))];
+  while (list != Val_int(0)) {
+    res |= flags[Int_val(Field(list, 0))];
     list = Field(list, 1);
   }
   return res;

File byterun/compare.c

 value equal(v1, v2)            /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) == 0);
+  return Val_int(compare_val(v1, v2) == 0);
 }
 
 value notequal(v1, v2)            /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) != 0);
+  return Val_int(compare_val(v1, v2) != 0);
 }
 
 value lessthan(v1, v2)            /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) < 0);
+  return Val_int(compare_val(v1, v2) < 0);
 }
 
 value lessequal(v1, v2)          /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) <= 0);
+  return Val_int(compare_val(v1, v2) <= 0);
 }
 
 value greaterthan(v1, v2)        /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) > 0);
+  return Val_int(compare_val(v1, v2) > 0);
 }
 
 value greaterequal(v1, v2)       /* ML */
      value v1, v2;
 {
-  return Atom(compare_val(v1, v2) >= 0);
+  return Val_int(compare_val(v1, v2) >= 0);
 }
 

File byterun/fix_code.c

     case GETGLOBALFIELD: case MAKEBLOCK: case C_CALLN:
       p += 2; break;
       /* Instructions with N+1 operands */
-    case SWITCH: case TRANSLATE:
+    case SWITCH:
+      { uint32 sizes = *p++;
+        uint32 const_size = sizes & 0xFFFF;
+        uint32 block_size = sizes >> 16;
+        p += const_size + block_size;
+        break; }
+    case TRANSLATE:
       p += *p + 1; break;
     }
   }

File byterun/floats.c

 
 #ifdef ALIGN_DOUBLE
 
+#if defined(__GNUC__) && defined(__sparc__)
+
+/* GCC for the Sparc is the major offender here, since it uses ldd and std
+   to operate on doubles, therefore requiring 8-alignment of doubles.
+   This is a hack to coerce GCC into generating the right code: two ld
+   or two st. */
+
+inline double Double_val(val)
+     value val;
+{
+  double result;
+  asm("ld [%1], %0; ld [%1+4], %R0" : "=f" (result) : "r" (val));
+  return result;
+}
+
+inline void Store_double_val(val, dbl)
+     value val;
+     double dbl;
+{
+  asm("st %0, [%1]; st %R0, [%1+4]" : : "r" (dbl), "r" (val));
+}
+
+#else
+
 double Double_val(val)
      value val;
 {
 }
 
 #endif
+#endif
 
 value format_float(fmt, arg)    /* ML */
      value fmt, arg;

File byterun/gc_ctrl.c

   char *cur_hp, *prev_hp;
   header_t cur_hd;
 
-  Assert (v == Atom (0));
+  Assert (v == Val_unit);
 
   while (chunk != NULL){
     ++ heap_chunks;
 {
   value res;
 
-  Assert (v == Atom (0));
+  Assert (v == Val_unit);
   res = alloc (4, 0);
   Field (res, 0) = Wsize_bsize (Val_long (minor_heap_size));
   Field (res, 1) = Wsize_bsize (Val_long (major_heap_increment));
     gc_message ("New minor heap size: %ldk\n", new_size/1024);
     set_minor_heap_size (new_size);
   }
-  return Atom (0);
+  return Val_unit;
 }
 
 value gc_minor(v) /* ML */
     value v;
-{                                                    Assert (v == Atom (0));
+{                                                    Assert (v == Val_unit);
   minor_collection ();
-  return Atom (0);
+  return Val_unit;
 }
 
 value gc_major(v) /* ML */
     value v;
-{                                                    Assert (v == Atom (0));
+{                                                    Assert (v == Val_unit);
   minor_collection ();
   finish_major_cycle ();
-  return Atom (0);
+  return Val_unit;
 }
 
 value gc_full_major(v) /* ML */
     value v;
-{                                                    Assert (v == Atom (0));
+{                                                    Assert (v == Val_unit);
   minor_collection ();
   finish_major_cycle ();
   finish_major_cycle ();
-  return Atom (0);
+  return Val_unit;
 }
 
 void init_gc (minor_size, major_incr, percent_fr, verb)

File byterun/hash.c

     return;
   }
 
-  /* Atoms are not in the heap, but it's better to hash their tag
-     than to do nothing. */
-
-  if (Is_atom(obj)) {
-    tag = Tag_val(obj);
-    hash_univ_count--;
-    Combine_small(tag);
-    return;
-  }
-
   /* Pointers into the heap are well-structured blocks.
      We can inspect the block contents. */
   

File byterun/instruct.h

   RETURN, RESTART, GRAB,
   CLOSURE, CLOSUREREC,
   GETGLOBAL, PUSHGETGLOBAL, GETGLOBALFIELD, PUSHGETGLOBALFIELD, SETGLOBAL,
-  ATOM0, ATOM1, ATOM2, ATOM3, ATOM,
-  PUSHATOM0, PUSHATOM1, PUSHATOM2, PUSHATOM3, PUSHATOM,
+  ATOM0, ATOM, PUSHATOM0, PUSHATOM,
   MAKEBLOCK, MAKEBLOCK1, MAKEBLOCK2, MAKEBLOCK3,
   GETFIELD0, GETFIELD1, GETFIELD2, GETFIELD3, GETFIELD,
   SETFIELD0, SETFIELD1, SETFIELD2, SETFIELD3, SETFIELD,
-  TAGOF, DUMMY, UPDATE,
+  DUMMY, UPDATE,
   VECTLENGTH, GETVECTITEM, SETVECTITEM,
   GETSTRINGCHAR, SETSTRINGCHAR, 
   BRANCH, BRANCHIF, BRANCHIFNOT, SWITCH, TRANSLATE, BOOLNOT,
   PUSHTRAP, POPTRAP, RAISE, CHECK_SIGNALS,
   C_CALL1, C_CALL2, C_CALL3, C_CALL4, C_CALLN,
-  CONSTINT, PUSHCONSTINT,
+  CONST0, CONST1, CONST2, CONST3, CONSTINT,
+  PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT,
   NEGINT, ADDINT, SUBINT, MULINT, DIVINT, MODINT,
   ANDINT, ORINT, XORINT, LSLINT, LSRINT, ASRINT,
   EQ, NEQ, LTINT, LEINT, GTINT, GEINT,

File byterun/interp.c

   pc = prog;
   extra_args = 0;
   env = Atom(0);
-  accu = Val_long(0);
+  accu = Val_int(0);
   initial_local_roots = local_roots;
   initial_sp_offset = stack_high - sp;
   initial_external_raise = external_raise;
 
 /* Allocation of blocks */
 
+    Instruct(PUSHATOM0):
+      *--sp = accu;
+      /* Fallthrough */
     Instruct(ATOM0):
       accu = Atom(0); Next;
-    Instruct(ATOM1):
-      accu = Atom(1); Next;
-    Instruct(ATOM2):
-      accu = Atom(2); Next;
-    Instruct(ATOM3):
-      accu = Atom(3); Next;
-
-    Instruct(PUSHATOM0):
-      *--sp = accu; accu = Atom(0); Next;
-    Instruct(PUSHATOM1):
-      *--sp = accu; accu = Atom(1); Next;
-    Instruct(PUSHATOM2):
-      *--sp = accu; accu = Atom(2); Next;
-    Instruct(PUSHATOM3):
-      *--sp = accu; accu = Atom(3); Next;
 
     Instruct(PUSHATOM):
       *--sp = accu;
       /* Fallthrough */
     Instruct(ATOM):
-      accu = Atom(*pc);
-      pc++;
-      Next;
+      accu = Atom(*pc++); Next;
 
     Instruct(MAKEBLOCK): {
       mlsize_t wosize = *pc++;
       modify_newval = *sp++;
       goto modify;
 
-    Instruct(TAGOF):
-      accu = Val_int(Tag_val(accu));
-      Next;
-
 /* For recursive definitions */
 
     Instruct(DUMMY): {
       pc += *pc;
       Next;
     Instruct(BRANCHIF):
-      if (Tag_val(accu) != 0) pc += *pc; else pc++;
+      if (accu != Val_false) pc += *pc; else pc++;
       Next;
     Instruct(BRANCHIFNOT):
-      if (Tag_val(accu) == 0) pc += *pc; else pc++;
+      if (accu == Val_false) pc += *pc; else pc++;
       Next;
     Instruct(SWITCH): {
-      long index = Long_val(accu);
-      Assert(index >= 0 && index < *pc);
-      pc++;
-      pc += pc[index];
+      uint32 sizes = *pc++;
+      if (Is_block(accu)) {
+        long index = Tag_val(accu);
+        Assert(index >= 0 && index < (sizes >> 16));
+        pc += pc[(sizes & 0xFFFF) + index];
+      } else {
+        long index = Long_val(accu);
+        Assert(index >= 0 && index < (sizes & 0xFFFF));
+        pc += pc[index];
+      }
       Next;
     }
     Instruct(TRANSLATE): {
       Next;
     }
     Instruct(BOOLNOT):
-      accu = Atom(Tag_val(accu) == 0);
+      accu = Bool_val(accu == Val_false);
       Next;
 
 /* Exceptions */
       Next;
     }
 
-/* Integer arithmetic */
+/* Integer constants */
+
+    Instruct(CONST0):
+      accu = Val_int(0); Next;
+    Instruct(CONST1):
+      accu = Val_int(1); Next;
+    Instruct(CONST2):
+      accu = Val_int(2); Next;
+    Instruct(CONST3):
+      accu = Val_int(3); Next;
+
+    Instruct(PUSHCONST0):
+      *--sp = accu; accu = Val_int(0); Next;
+    Instruct(PUSHCONST1):
+      *--sp = accu; accu = Val_int(1); Next;
+    Instruct(PUSHCONST2):
+      *--sp = accu; accu = Val_int(2); Next;
+    Instruct(PUSHCONST3):
+      *--sp = accu; accu = Val_int(3); Next;
 
-    Instruct(CONSTINT):
-      accu = Val_int(*pc);
-      pc++;
-      Next;
     Instruct(PUSHCONSTINT):
       *--sp = accu;
+      /* Fallthrough */
+    Instruct(CONSTINT):
       accu = Val_int(*pc);
       pc++;
       Next;
+
+/* Integer arithmetic */
+
     Instruct(NEGINT):
       accu = (value)(2 - (long)accu); Next;
     Instruct(ADDINT):
       accu = Val_long(Long_val(accu) * Long_val(*sp++)); Next;
     Instruct(DIVINT): {
       value div = *sp++;
-      if (div == Val_long(0)) {
-        accu = Field(global_data, ZERO_DIVIDE_EXN);
-        goto raise_exception;
-      }
+      if (div == Val_long(0)) { Setup_for_c_call; raise_zero_divide(); }
       accu = Val_long(Long_val(accu) / Long_val(div));
       Next;
     }
     Instruct(MODINT): {
       value div = *sp++;
-      if (div == Val_long(0)) {
-        accu = Field(global_data, ZERO_DIVIDE_EXN);
-        goto raise_exception;
-      }
+      if (div == Val_long(0)) { Setup_for_c_call; raise_zero_divide(); }
       accu = Val_long(Long_val(accu) % Long_val(div));
       Next;
     }
 
 #define Integer_comparison(opname,tst) \
     Instruct(opname): \
-      accu = Atom((long) accu tst (long) *sp++); Next;
+      accu = Val_int((long) accu tst (long) *sp++); Next;
 
     Integer_comparison(EQ, ==)
     Integer_comparison(NEQ, !=)

File byterun/io.c

     channel->curr = channel->buff;
     channel->max  = channel->buff;
   }
-  return Atom(0);
+  return Val_unit;
 }
 
 value output_char(channel, ch)  /* ML */
      value ch;
 {
   putch(channel, Long_val(ch));
-  return Atom(0);
+  return Val_unit;
 }
 
 void putword(channel, w)
      value w;
 {
   putword(channel, Long_val(w));
-  return Atom(0);
+  return Val_unit;
 }
 
 void putblock(channel, p, n)
   putblock((struct channel *) channel,
            &Byte(buff, Long_val(start)),
            (unsigned) Long_val(length));
-  return Atom(0);
+  return Val_unit;
 }
 
 value seek_out(channel, pos)    /* ML */
     if (lseek(channel->fd, dest, 0) != dest) sys_error(NULL);
     channel->offset = dest;
   }
-  return Atom(0);
+  return Val_unit;
 }
 
 value pos_out(channel)          /* ML */
   flush(channel);
   close(channel->fd);
   stat_free((char *) channel);
-  return Atom(0);
+  return Val_unit;
 }
 
 /* Input */
     channel->offset = dest;
     channel->curr = channel->max = channel->buff;
   }
-  return Atom(0);
+  return Val_unit;
 }
 
 value pos_in(channel)           /* ML */
 {
   close(channel->fd);
   stat_free((char *) channel);
-  return Atom(0);
+  return Val_unit;
 }
 
 value input_scan_line(channel)       /* ML */

File byterun/meta.c

     }
     global_data = new_global_data;
   }
-  return Atom(0);
+  return Val_unit;
 }
     
 value static_alloc(size)        /* ML */
      value blk;
 {
   stat_free((char *) blk);
-  return Atom(0);
+  return Val_unit;
 }
 
 value static_resize(blk, new_size) /* ML */
 value obj_is_block(arg)             /* ML */
      value arg;
 {
-  return Atom(Is_block(arg));
+  return Val_bool(Is_block(arg));
+}
+
+value obj_tag(arg)                 /* ML */
+     value arg;
+{
+  return Val_int(Tag_val(arg));
 }
 
 value obj_block(tag, size) /* ML */

File byterun/mlvalues.h

 #define Atom(tag) (Val_hp (&(first_atoms [tag])))
 #define Is_atom(v) (v >= Atom(0) && v <= Atom(255))
 
-/* Booleans are atoms tagged 0 or 1 */
+/* Booleans are integers 0 or 1 */
 
-#define Val_bool(x) Atom((x) != 0)
-#define Bool_val(x) Tag_val(x)
-#define Val_false Atom(0)
-#define Val_true Atom(1)
+#define Val_bool(x) Val_int((x) != 0)
+#define Bool_val(x) Int_val(x)
+#define Val_false Val_int(0)
+#define Val_true Val_int(1)
 
-/* The unit value is the atom tagged 0 */
+/* The unit value is 0 */
 
-#define Val_unit Atom(0)
+#define Val_unit Val_int(0)
 
 /* The table of global identifiers */
 

File byterun/parsing.c

 
 struct parser_tables {    /* Mirrors parse_tables in ../stdlib/parsing.mli */
   value actions;
-  value transl;
+  value transl_const;
+  value transl_block;
   char * lhs;
   char * len;
   char * defred;
 #endif
 
 /* Input codes */
-
-#define START 0            /* Mirrors parser_input in ../stdlib/parsing.ml */
+/* Mirrors parser_input in ../stdlib/parsing.ml */
+#define START 0
 #define TOKEN_READ 1
 #define STACKS_GROWN_1 2
 #define STACKS_GROWN_2 3
 #define SEMANTIC_ACTION_COMPUTED 4
 
 /* Output codes */
-
-#define READ_TOKEN Atom(0) /* Mirrors parser_output in ../stdlib/parsing.ml */
-#define RAISE_PARSE_ERROR Atom(1)
-#define GROW_STACKS_1 Atom(2)
-#define GROW_STACKS_2 Atom(3)
-#define COMPUTE_SEMANTIC_ACTION Atom(4)
+/* Mirrors parser_output in ../stdlib/parsing.ml */
+#define READ_TOKEN Val_int(0) 
+#define RAISE_PARSE_ERROR Val_int(1)
+#define GROW_STACKS_1 Val_int(2)
+#define GROW_STACKS_2 Val_int(3)
+#define COMPUTE_SEMANTIC_ACTION Val_int(4)
 
 /* The pushdown automata */
 
   mlsize_t sp;
   int n, n1, n2, m, state1;
 
-  switch(Tag_val(cmd)) {
+  switch(Int_val(cmd)) {
 
   case START:
     state = 0;
   case TOKEN_READ:
     sp = Int_val(env->sp);
     state = Int_val(env->state);
-    env->curr_char = Field(tables->transl, Tag_val(arg));
-    switch (Wosize_val(arg)) {
-    case 0:
-      env->lval = Val_long(0); break;
-    case 1:
-      modify(&env->lval, Field(arg, 0)); break;
-    default: {
-      value tuple;
-      mlsize_t size, i;
-      Push_roots(r, 4);
-      r[0] = (value) tables;
-      r[1] = (value) env;
-      r[2] = cmd;
-      r[3] = arg;
-      size = Wosize_val(arg);
-      tuple = alloc_tuple(size);
-      tables = (struct parser_tables *) r[0];
-      env = (struct parser_env *) r[1];
-      cmd = r[2];
-      arg = r[3];
-      for (i = 0; i < size; i++) Field(tuple, i) = Field(arg, i);
-      modify(&env->lval, tuple);
-      Pop_roots();
-      break; }
+    if (Is_block(arg)) {
+      env->curr_char = Field(tables->transl_block, Tag_val(arg));
+      modify(&env->lval, Field(arg, 0));
+    } else {
+      env->curr_char = Field(tables->transl_const, Int_val(arg));
+      env->lval = Val_long(0);
     }
     Trace(printf("Token %d (0x%lx)\n", Int_val(env->curr_char), env->lval));
     

File byterun/str.c

   bcopy(&Byte(argv[0], Long_val(argv[1])),
         &Byte(argv[2], Long_val(argv[3])),
         Int_val(argv[4]));
-  return Atom(0);
+  return Val_unit;
 }
 
 value fill_string(s, offset, len, init) /* ML */
   for(p = &Byte(s, Long_val(offset)), n = Long_val(len);
       n > 0; n--, p++)
     *p = c;
-  return Atom(0);
+  return Val_unit;
 }
 
 static unsigned char printable_chars_ascii[] = /* 0x20-0x7E */

File byterun/sys.c

   int ret;
   ret = unlink(String_val(name));
   if (ret != 0) sys_error(String_val(name));
-  return Atom(0);
+  return Val_unit;
 }
 
 value sys_rename(oldname, newname) /* ML */
 {
   if (rename(String_val(oldname), String_val(newname)) != 0)
     sys_error(String_val(oldname));
-  return Atom(0);
+  return Val_unit;
 }
 
 value sys_chdir(dirname)        /* ML */
      value dirname;
 {
   if (chdir(String_val(dirname)) != 0) sys_error(String_val(dirname));
-  return Atom(0);
+  return Val_unit;
 }
 
 value sys_getenv(var)           /* ML */