← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to asmcomp/cmmgen.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stefano Zacchiroli
  • Date: 2009-02-22 08:49:13 UTC
  • mfrom: (12.1.1 squeeze)
  • Revision ID: james.westby@ubuntu.com-20090222084913-3i0uw2bhd0lgw0ok
* Uploading to unstable
* debian/control: bump dh-ocaml to (>= 0.4) to avoid buggy ocamlinit.mk

Show diffs side-by-side

added added

removed removed

Lines of Context:
asmcomp/cmmgen.ml
10
10
(*                                                                     *)
11
11
(***********************************************************************)
12
12
 
13
 
(* $Id: cmmgen.ml,v 1.109 2007/02/22 12:13:00 xleroy Exp $ *)
 
13
(* $Id: cmmgen.ml,v 1.114 2008/08/05 13:35:20 xleroy Exp $ *)
14
14
 
15
15
(* Translation from closed lambda to C-- *)
16
16
 
180
180
 
181
181
let box_float c = Cop(Calloc, [alloc_float_header; c])
182
182
 
183
 
let unbox_float = function
 
183
let rec unbox_float = function
184
184
    Cop(Calloc, [header; c]) -> c
 
185
  | Clet(id, exp, body) -> Clet(id, exp, unbox_float body)
 
186
  | Cifthenelse(cond, e1, e2) ->
 
187
      Cifthenelse(cond, unbox_float e1, unbox_float e2)
 
188
  | Csequence(e1, e2) -> Csequence(e1, unbox_float e2)
 
189
  | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el)
 
190
  | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2)
 
191
  | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2)
185
192
  | c -> Cop(Cload Double_u, [c])
186
193
 
187
194
(* Complex *)
469
476
                   Cconst_symbol(operations_boxed_int bi);
470
477
                   arg'])
471
478
 
472
 
let unbox_int bi arg =
 
479
let rec unbox_int bi arg =
473
480
  match arg with
474
481
    Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])])
475
482
    when bi = Pint32 && size_int = 8 && big_endian ->
481
488
      Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32])
482
489
  | Cop(Calloc, [hdr; ops; contents]) ->
483
490
      contents
 
491
  | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body)
 
492
  | Cifthenelse(cond, e1, e2) ->
 
493
      Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2)
 
494
  | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2)
 
495
  | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el)
 
496
  | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2)
 
497
  | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2)
484
498
  | _ ->
485
499
      Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word),
486
500
          [Cop(Cadda, [arg; Cconst_int size_addr])])
507
521
  | Pbigarray_complex32 -> 8
508
522
  | Pbigarray_complex64 -> 16
509
523
 
510
 
let bigarray_indexing elt_kind layout b args dbg =
 
524
let bigarray_indexing unsafe elt_kind layout b args dbg =
 
525
  let check_bound a1 a2 k =
 
526
    if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in
511
527
  let rec ba_indexing dim_ofs delta_ofs = function
512
528
    [] -> assert false
513
529
  | [arg] ->
514
530
      bind "idx" (untag_int arg)
515
531
        (fun idx ->
516
 
          Csequence(
517
 
            Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]),
518
 
            idx))
 
532
           check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx)
519
533
  | arg1 :: argl ->
520
534
      let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in
521
535
      bind "idx" (untag_int arg1)
522
536
        (fun idx ->
523
537
          bind "bound" (Cop(Cload Word, [field_address b dim_ofs]))
524
538
          (fun bound ->
525
 
            Csequence(Cop(Ccheckbound dbg, [bound; idx]),
526
 
                      add_int (mul_int rem bound) idx))) in
 
539
            check_bound bound idx (add_int (mul_int rem bound) idx))) in
527
540
  let offset =
528
541
    match layout with
529
542
      Pbigarray_unknown_layout ->
555
568
  | Pbigarray_complex32 -> Single
556
569
  | Pbigarray_complex64 -> Double
557
570
 
558
 
let bigarray_get elt_kind layout b args dbg =
 
571
let bigarray_get unsafe elt_kind layout b args dbg =
559
572
  match elt_kind with
560
573
    Pbigarray_complex32 | Pbigarray_complex64 ->
561
574
      let kind = bigarray_word_kind elt_kind in
562
575
      let sz = bigarray_elt_size elt_kind / 2 in
563
 
      bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr ->
 
576
      bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
564
577
        box_complex
565
578
          (Cop(Cload kind, [addr]))
566
579
          (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
567
580
  | _ ->
568
581
      Cop(Cload (bigarray_word_kind elt_kind),
569
 
          [bigarray_indexing elt_kind layout b args dbg])
 
582
          [bigarray_indexing unsafe elt_kind layout b args dbg])
570
583
 
571
 
let bigarray_set elt_kind layout b args newval dbg =
 
584
let bigarray_set unsafe elt_kind layout b args newval dbg =
572
585
  match elt_kind with
573
586
    Pbigarray_complex32 | Pbigarray_complex64 ->
574
587
      let kind = bigarray_word_kind elt_kind in
575
588
      let sz = bigarray_elt_size elt_kind / 2 in
576
589
      bind "newval" newval (fun newv ->
577
 
      bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr ->
 
590
      bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
578
591
        Csequence(
579
592
          Cop(Cstore kind, [addr; complex_re newv]),
580
593
          Cop(Cstore kind,
581
594
              [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
582
595
  | _ ->
583
596
      Cop(Cstore (bigarray_word_kind elt_kind),
584
 
          [bigarray_indexing elt_kind layout b args dbg; newval])
 
597
          [bigarray_indexing unsafe elt_kind layout b args dbg; newval])
585
598
 
586
599
(* Simplification of some primitives into C calls *)
587
600
 
616
629
  | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan")
617
630
  | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal")
618
631
  | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal")
619
 
  | Pbigarrayref(n, Pbigarray_int64, layout) ->
 
632
  | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) ->
620
633
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
621
 
  | Pbigarrayset(n, Pbigarray_int64, layout) ->
 
634
  | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) ->
622
635
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
623
636
  | p -> p
624
637
 
626
639
  match p with
627
640
  | Pduprecord _ ->
628
641
      Pccall (default_prim "caml_obj_dup")
629
 
  | Pbigarrayref(n, Pbigarray_unknown, layout) ->
 
642
  | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) ->
630
643
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
631
 
  | Pbigarrayset(n, Pbigarray_unknown, layout) ->
 
644
  | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) ->
632
645
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
633
 
  | Pbigarrayref(n, kind, Pbigarray_unknown_layout) ->
 
646
  | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) ->
634
647
      Pccall (default_prim ("caml_ba_get_" ^ string_of_int n))
635
 
  | Pbigarrayset(n, kind, Pbigarray_unknown_layout) ->
 
648
  | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) ->
636
649
      Pccall (default_prim ("caml_ba_set_" ^ string_of_int n))
637
650
  | p ->
638
651
      if size_int = 8 then p else simplif_primitive_32bits p
729
742
        | Plslbint bi -> Boxed_integer bi
730
743
        | Plsrbint bi -> Boxed_integer bi
731
744
        | Pasrbint bi -> Boxed_integer bi
732
 
        | Pbigarrayref(_, (Pbigarray_float32 | Pbigarray_float64), _) ->
 
745
        | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) ->
733
746
            Boxed_float
734
 
        | Pbigarrayref(_, Pbigarray_int32, _) -> Boxed_integer Pint32
735
 
        | Pbigarrayref(_, Pbigarray_int64, _) -> Boxed_integer Pint64
736
 
        | Pbigarrayref(_, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
 
747
        | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32
 
748
        | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64
 
749
        | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint
737
750
        | _ -> No_unboxing
738
751
      end
739
752
  | _ -> No_unboxing
869
882
            box_float
870
883
              (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg),
871
884
                   List.map transl_unbox_float args))
872
 
          else begin
873
 
            let name =
874
 
              if prim.prim_native_name <> ""
875
 
              then prim.prim_native_name
876
 
              else prim.prim_name in
877
 
            Cop(Cextcall(name, typ_addr, prim.prim_alloc, dbg),
 
885
          else
 
886
            Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg),
878
887
                List.map transl args)
879
 
          end
880
888
      | (Pmakearray kind, []) ->
881
889
          transl_constant(Const_block(0, []))
882
890
      | (Pmakearray kind, args) ->
890
898
              make_float_alloc Obj.double_array_tag
891
899
                              (List.map transl_unbox_float args)
892
900
          end
893
 
      | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) ->
 
901
      | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
894
902
          let elt =
895
 
            bigarray_get elt_kind layout
 
903
            bigarray_get unsafe elt_kind layout
896
904
              (transl arg1) (List.map transl argl) dbg in
897
905
          begin match elt_kind with
898
906
            Pbigarray_float32 | Pbigarray_float64 -> box_float elt
903
911
          | Pbigarray_caml_int -> force_tag_int elt
904
912
          | _ -> tag_int elt
905
913
          end
906
 
      | (Pbigarrayset(num_dims, elt_kind, layout), arg1 :: argl) ->
 
914
      | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) ->
907
915
          let (argidx, argnewval) = split_last argl in
908
 
          return_unit(bigarray_set elt_kind layout
 
916
          return_unit(bigarray_set unsafe elt_kind layout
909
917
            (transl arg1)
910
918
            (List.map transl argidx)
911
919
            (match elt_kind with
1927
1935
  then intermediate_curry_functions arity 0
1928
1936
  else [tuplify_function (-arity)]
1929
1937
 
 
1938
 
 
1939
module IntSet = Set.Make(
 
1940
  struct
 
1941
    type t = int
 
1942
    let compare = compare
 
1943
  end)
 
1944
 
 
1945
let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty)
 
1946
  (* These apply funs are always present in the main program.
 
1947
     TODO: add more, and do the same for send and curry funs
 
1948
     (maybe up to 10-15?). *)
 
1949
 
 
1950
let generic_functions shared units =
 
1951
  let (apply,send,curry) =
 
1952
    List.fold_left
 
1953
      (fun (apply,send,curry) ui ->
 
1954
         List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply,
 
1955
         List.fold_right IntSet.add ui.Compilenv.ui_send_fun send,
 
1956
         List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry)
 
1957
      (IntSet.empty,IntSet.empty,IntSet.empty)
 
1958
      units
 
1959
  in
 
1960
  let apply =
 
1961
    if shared then IntSet.diff apply default_apply
 
1962
    else IntSet.union apply default_apply
 
1963
  in
 
1964
  let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in
 
1965
  let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in
 
1966
  IntSet.fold (fun n accu -> curry_function n @ accu) curry accu
 
1967
 
1930
1968
(* Generate the entry point *)
1931
1969
 
1932
1970
let entry_point namelist =
1961
1999
        List.map mksym namelist @
1962
2000
        [cint_zero])
1963
2001
 
1964
 
let globals_map namelist =
1965
 
  Cdata(Cglobal_symbol "caml_globals_map" ::
1966
 
        emit_constant "caml_globals_map"
1967
 
          (Const_base (Const_string (Marshal.to_string namelist []))) [])
 
2002
let reference_symbols namelist =
 
2003
  let mksym name = Csymbol_address name in
 
2004
  Cdata(List.map mksym namelist)
 
2005
 
 
2006
let global_data name v =
 
2007
  Cdata(Cglobal_symbol name ::
 
2008
          emit_constant name
 
2009
          (Const_base (Const_string (Marshal.to_string v []))) [])
 
2010
 
 
2011
let globals_map v = global_data "caml_globals_map" v
1968
2012
 
1969
2013
(* Generate the master table of frame descriptors *)
1970
2014
 
2006
2050
          Cint(block_header 0 1);
2007
2051
          Cdefine_symbol bucketname;
2008
2052
          Csymbol_address symname ])
 
2053
 
 
2054
(* Header for a plugin *)
 
2055
 
 
2056
let mapflat f l = List.flatten (List.map f l)
 
2057
 
 
2058
type dynunit = {
 
2059
  name: string;
 
2060
  crc: Digest.t;
 
2061
  imports_cmi: (string * Digest.t) list;
 
2062
  imports_cmx: (string * Digest.t) list;
 
2063
  defines: string list;
 
2064
}
 
2065
 
 
2066
type dynheader = {
 
2067
  magic: string;
 
2068
  units: dynunit list;
 
2069
}
 
2070
 
 
2071
let dyn_magic_number = "Caml2007D001"
 
2072
 
 
2073
let plugin_header units =
 
2074
  let mk (ui,crc) =
 
2075
    { name = ui.Compilenv.ui_name;
 
2076
      crc = crc;
 
2077
      imports_cmi = ui.Compilenv.ui_imports_cmi;
 
2078
      imports_cmx = ui.Compilenv.ui_imports_cmx;
 
2079
      defines = ui.Compilenv.ui_defines 
 
2080
    } in
 
2081
  global_data "caml_plugin_header"
 
2082
    { magic = dyn_magic_number; units = List.map mk units }