Portage Alpha-Linux

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

7 files changed, 119 insertions, 64 deletions

diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp
index 448c9bf61..fa437382d 100644
--- a/asmcomp/alpha/emit.mlp
+++ b/asmcomp/alpha/emit.mlp
@@ -25,14 +25,6 @@ open Mach
 open Linearize
 open Emitaux
 
-(* Determine if a function label is defined in the current compilation
-   unit *)
-
-let is_local s =
-  let cu = Compilenv.current_unit_name() in
-  let lcu = String.length cu in
-  String.length s >= lcu + 1 && String.sub s 0 lcu = cu && s.[lcu] = '.'
-
 (* First pass: insert Iloadgp instructions where needed *)
 
 let instr_copy i next =
@@ -65,11 +57,11 @@ let insert_load_gp f =
     | Lop(Iconst_float s) -> true       (* turned into ldq ($gp) *)
     | Lop(Iconst_symbol s) -> true      (* turned into ldq ($gp) *)
     | Lop(Icall_ind) -> false           (* does ldgp if needed afterwards *)
-    | Lop(Icall_imm s) ->               (* loads $27 from ($gp) if external *)
-        not (is_local s)
+    | Lop(Icall_imm s) -> true          (* loads $27 from ($gp) if external, *)
+                                        (* and assume $gp set if internal *)
     | Lop(Itailcall_ind) -> false
-    | Lop(Itailcall_imm s) ->           (* loads $27 from ($gp) *)
-        s <> f.fun_name && not(is_local s)
+    | Lop(Itailcall_imm s) -> true      (* loads $27 from ($gp) if external *)
+                                        (* and assume $gp set if internal *)
     | Lop(Iextcall(_, _)) -> true       (* loads $27 from ($gp) *)
     | Lop(Iload(_, Ibased(_, _))) -> true (* loads address from ($gp) *)
     | Lop(Istore(_, Ibased(_, _))) -> true (* loads address from ($gp) *)
@@ -127,9 +119,9 @@ let insert_load_gp f =
       (new_instr, instr_needs_gp needs_next i.desc)
     end in
 
-  { fun_body = insert_reload_gp f.fun_body;
-    fun_name = f.fun_name;
-    fun_fast = f.fun_fast }
+  let (new_body, uses_gp) = insert_reload_gp f.fun_body in
+  ({fun_body = new_body; fun_name = f.fun_name; fun_fast = f.fun_fast},
+   uses_gp)
 
 (* Second pass: code generation proper *)
 
@@ -206,7 +198,7 @@ let int_reg_number = [|
   
 let float_reg_number = [|
   0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15;
-  16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 28; 29
+  16; 17; 18; 19; 20; 21; 22; 23; 24; 25; 26; 27; 29; 30
 |]
 
 let liveregs instr extra_msk =
@@ -267,6 +259,13 @@ let emit_frame fd =
     fd.fd_live_offset;
   `	.align	3\n`
 
+(* Work around a bug in gas regarding the parsing of long decimal constants *)
+
+let emit_nativeint =
+  if digital_asm
+  then Emitaux.emit_nativeint
+  else (fun n -> emit_string(Nativeint.to_hexa_string n))
+
 (* Record calls to the GC -- we've moved them out of the way *)
 
 type gc_call =
@@ -340,6 +339,14 @@ let name_for_float_comparison cmp neg =
   | Cle -> ("cmptle", false, neg)  | Cgt -> ("cmptlt", true, neg)
   | Clt -> ("cmptlt", false, neg)  | Cge -> ("cmptle", true, neg)
 
+(* Determine if a function label is defined in the current compilation
+   unit *)
+
+let is_local s =
+  let cu = Compilenv.current_unit_name() in
+  let lcu = String.length cu in
+  String.length s >= lcu + 1 && String.sub s 0 lcu = cu && s.[lcu] = '.'
+
 (* Local entry points for functions defined in the current compilation unit *)
 
 let local_entry_points = (Hashtbl.create 19 : (string, label) Hashtbl.t)
@@ -365,6 +372,8 @@ let function_name = ref ""
 let tailrec_entry_point = ref 0
 (* Label of trap for out-of-range accesses *)
 let range_check_trap = ref 0
+(* List of floating-point literals (fon non-Digital assemblers) *)
+let float_constants = ref ([] : (label * string) list)
 
 let emit_instr i =
     match i.desc with
@@ -397,7 +406,16 @@ let emit_instr i =
         else
           `	ldiq	{emit_reg i.res.(0)}, {emit_nativeint n}\n`
     | Lop(Iconst_float s) ->
-        `	ldit	{emit_reg i.res.(0)}, {emit_string s}\n`
+        if digital_asm then
+          `	ldit	{emit_reg i.res.(0)}, {emit_string s}\n`
+        else if float_of_string s = 0.0 then
+          `	fmov	$f31, {emit_reg i.res.(0)}\n`
+        else begin
+          let lbl = new_label() in
+          float_constants := (lbl, s) :: !float_constants;
+          `	lda	$25, {emit_label lbl}\n`;
+          `	ldt     {emit_reg i.res.(0)}, 0($25)\n`
+        end
     | Lop(Iconst_symbol s) ->
         `	lda	{emit_reg i.res.(0)}, {emit_symbol s}\n`
     | Lop(Icall_ind) ->
@@ -477,7 +495,12 @@ let emit_instr i =
               gc_return_lbl = lbl_redo;
               gc_frame = lbl_frame;
               gc_instr = i } :: !call_gc_sites;
-          `{emit_label lbl_redo}:	subq	$13, {emit_int n}, $13\n`;
+          if is_immediate n then
+            `{emit_label lbl_redo}:	subq	$13, {emit_int n}, $13\n`
+          else begin
+            `{emit_label lbl_redo}:	ldiq	$25, {emit_int n}\n`;
+            `	subq	$13, $25, $13\n`
+          end;
           `	cmpult	$13, $14, $25\n`;
           `	bne	$25, {emit_label lbl_call_gc}\n`;
           `	addq	$13, 8, {emit_reg i.res.(0)}\n`
@@ -513,7 +536,7 @@ let emit_instr i =
         if is_immediate n then
           `	addq	{emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`
         else begin
-          `	ldiq	$25, {emit_int n}\n`;
+          `	ldiq	$25, {emit_int(n-1)}\n`;
           `	addq	{emit_reg i.arg.(0)}, $25, $25\n`
         end;
         `	cmovge	{emit_reg i.arg.(0)}, {emit_reg i.arg.(0)}, $25\n`;
@@ -521,10 +544,10 @@ let emit_instr i =
     | Lop(Iintop_imm(Imod, n)) when n = 1 lsl (Misc.log2 n) ->
         let l = Misc.log2 n in
         if is_immediate n then
-          `	and	{emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`;
+          `	and	{emit_reg i.arg.(0)}, {emit_int(n-1)}, $25\n`
         else begin
-          `	ldiq	$25, {emit_int n}\n`;
-          `	and	{emit_reg i.arg.(0)}, $25, $25\n`;
+          `	ldiq	$25, {emit_int (n-1)}\n`;
+          `	and	{emit_reg i.arg.(0)}, $25, $25\n`
         end;
         `	subq	$25, {emit_int n}, $24\n`;
         `	cmovge	{emit_reg i.arg.(0)}, $25, $24\n`;
@@ -550,17 +573,21 @@ let emit_instr i =
         let instr = name_for_float_operation op in
         `	{emit_string instr}	{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.res.(0)}\n`
     | Lop(Ifloatofint) ->
+        `	.set	noat\n`;
         `	lda	$sp, -8($sp)\n`;
         `	stq	{emit_reg i.arg.(0)}, 0($sp)\n`;
-        `	ldt	$f30, 0($sp)\n`;
-        `	cvtqt	$f30, {emit_reg i.res.(0)}\n`;
-        `	lda	$sp, 8($sp)\n`
+        `	ldt	$f28, 0($sp)\n`;
+        `	cvtqt	$f28, {emit_reg i.res.(0)}\n`;
+        `	lda	$sp, 8($sp)\n`;
+        `	.set	at\n`
     | Lop(Iintoffloat) ->
+        `	.set	noat\n`;
         `	lda	$sp, -8($sp)\n`;
-        `	cvttqc	{emit_reg i.arg.(0)}, $f30\n`;
-        `	stt	$f30, 0($sp)\n`;
+        `	cvttqc	{emit_reg i.arg.(0)}, $f28\n`;
+        `	stt	$f28, 0($sp)\n`;
         `	ldq	{emit_reg i.res.(0)}, 0($sp)\n`;
-        `	lda	$sp, 8($sp)\n`
+        `	lda	$sp, 8($sp)\n`;
+        `	.set	at\n`
     | Lop(Ispecific(Ireloadgp marked_r26)) ->
         if marked_r26 then begin
           `	bic	$26, 1, $26\n`;
@@ -608,14 +635,16 @@ let emit_instr i =
             else
               `	beq	$25, {emit_label lbl}\n`
         | Ifloattest(cmp, neg) ->
+            `	.set	noat\n`;
             let (comp, swap, test) = name_for_float_comparison cmp neg in
             `	{emit_string comp}	`;
             if swap
-            then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f30\n`
-            else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f30\n`;
+            then `{emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, $f28\n`
+            else `{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, $f28\n`;
             if test
-            then `	fbeq	$f30, {emit_label lbl}\n`
-            else `	fbne	$f30, {emit_label lbl}\n`
+            then `	fbeq	$f28, {emit_label lbl}\n`
+            else `	fbne	$f28, {emit_label lbl}\n`;
+            `	.set	at\n`
         | Ioddtest ->
             `	blbs	{emit_reg i.arg.(0)}, {emit_label lbl}\n`
         | Ieventest ->
@@ -681,6 +710,7 @@ let emit_fundecl (fundecl, needs_gp) =
   stack_offset := 0;
   call_gc_sites := [];
   range_check_trap := 0;
+  float_constants := [];
   `	.text\n`;
   `	.align	4\n`;
   `	.globl	{emit_symbol fundecl.fun_name}\n`;
@@ -715,7 +745,14 @@ let emit_fundecl (fundecl, needs_gp) =
     `	br	$25, call_array_bound_error\n`
     (* Keep retaddr in $25 for debugging *)
   end;
-  `	.end	{emit_symbol fundecl.fun_name}\n`
+  `	.end	{emit_symbol fundecl.fun_name}\n`;
+  if !float_constants <> [] then begin
+    `	.section .rodata\n`;
+    `	.align	3\n`;
+    List.iter
+      (fun (lbl, s) -> `{emit_label lbl}:	.t_floating {emit_string s}\n`)
+      !float_constants
+  end
 
 let fundecl f =
   emit_fundecl (insert_load_gp f)
@@ -794,7 +831,11 @@ let end_assembly () =
   `{emit_symbol lbl_end}:\n`;
   `	.quad	0\n`;
   let lbl_frame = Compilenv.current_unit_name() ^ "_frametable" in
-  `	.rdata\n`;
+  begin match Config.system with
+    "digital" -> `	.rdata\n`
+  | "linux"   -> `	.section .rodata\n`
+  | _         -> assert false
+  end;
   `	.globl	{emit_symbol lbl_frame}\n`;
   `{emit_symbol lbl_frame}:\n`;
   `	.quad	{emit_int (List.length !frame_descriptors)}\n`;
diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml
index 36876a39b..f2e88177b 100644
--- a/asmcomp/alpha/proc.ml
+++ b/asmcomp/alpha/proc.ml
@@ -39,8 +39,8 @@ let word_addressed = true
     $f0 - $f7   100 - 107   function results
     $f8 - $f15  108 - 115   general purpose ($f2 - $f9 preserved by C)
     $f16 - $f23 116 - 123   function arguments
-    $f24 - $f29 124 - 129   general purpose
-    $f30                    temporary
+    $f24 - $f30 124 - 129   general purpose
+    $f28                    temporary
     $f31                    always zero *)
 
 let int_reg_name = [|
@@ -53,7 +53,7 @@ let float_reg_name = [|
   (* 100-107 *) "$f0"; "$f1"; "$f2"; "$f3"; "$f4"; "$f5"; "$f6"; "$f7";
   (* 108-115 *) "$f8"; "$f9"; "$f10"; "$f11"; "$f12"; "$f13"; "$f14"; "$f15";
   (* 116-123 *) "$f16"; "$f17"; "$f18"; "$f19"; "$f20"; "$f21"; "$f22"; "$f23";
-  (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f28"; "$f29"
+  (* 124-129 *) "$f24"; "$f25"; "$f26"; "$f27"; "$f29"; "$f30"
 |]
 
 let num_register_classes = 2
@@ -204,6 +204,11 @@ let contains_calls = ref false
 
 (* Calling the assembler *)
 
+let as_cmd =
+  if digital_asm
+  then "as -O2 -nocpp -o "
+  else "as -o "
+
 let assemble_file infile outfile =
-  Ccomp.command ("as -O2 -nocpp -o " ^ outfile ^ " " ^ infile)
+  Ccomp.command (as_cmd ^ outfile ^ " " ^ infile)
 
diff --git a/asmcomp/alpha/scheduling.ml b/asmcomp/alpha/scheduling.ml
index c05ff3959..67d125c67 100644
--- a/asmcomp/alpha/scheduling.ml
+++ b/asmcomp/alpha/scheduling.ml
@@ -11,6 +11,7 @@
 
 (* $Id$ *)
 
+open Arch
 open Mach
 
 (* The Digital Unix assembler does scheduling better than us.
@@ -27,7 +28,7 @@ method oper_latency = function
     Ireload -> 3
   | Iload(_, _) -> 3
   | Iconst_symbol _ -> 3 (* turned into a load *)
-  | Iconst_float _ -> 3 (* turned into a load *)
+  | Iconst_float _ -> 3 (* ends up in a load *)
   | Iintop(Imul) -> 23
   | Iintop_imm(Imul, _) -> 23
   | Iaddf -> 6
@@ -43,7 +44,8 @@ method oper_latency = function
 (* Issue cycles.  Rough approximations. *)
 
 method oper_issue_cycles = function
-    Ialloc _ -> 4
+    Iconst_float _ -> 4                 (* load from $gp, then load *)
+  | Ialloc _ -> 4
   | Iintop(Icheckbound) -> 2
   | Iintop_imm(Idiv, _) -> 3
   | Iintop_imm(Imod, _) -> 5
@@ -62,6 +64,6 @@ method oper_in_basic_block = function
 end
 
 let fundecl =
-  if Arch.digital_asm
+  if digital_asm
   then (fun f -> f)
-  else (new scheduler ())#fundecl
+  else (new scheduler ())#schedule_fundecl
diff --git a/asmcomp/alpha/selection.ml b/asmcomp/alpha/selection.ml
index 60f296c8b..14cb53d8f 100644
--- a/asmcomp/alpha/selection.ml
+++ b/asmcomp/alpha/selection.ml
@@ -27,10 +27,10 @@ method is_immediate n = digital_asm || (n >= 0 && n <= 255)
 
 method select_addressing = function
     (* Force an explicit lda for non-scheduling assemblers,
-       this allows our scheduler to do a better job of it. *)
+       this allows our scheduler to do a better job. *)
     Cconst_symbol s when digital_asm ->
       (Ibased(s, 0), Ctuple [])
-  | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) ->
+  | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) when digital_asm ->
       (Ibased(s, n), Ctuple [])
   | Cop(Cadda, [arg; Cconst_int n]) ->
       (Iindexed n, arg)
diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml
index c064d7541..3f8b06179 100644
--- a/asmcomp/schedgen.ml
+++ b/asmcomp/schedgen.ml
@@ -231,15 +231,15 @@ method reschedule ready_queue date cont =
         (* Update the start date and number of ancestors emitted of
            all descendents of this node. Enter those that become ready
            in the queue. *)
+        let issue_cycles = self#instr_issue_cycles node.instr in
         List.iter
           (fun (son, delay) ->
-            let completion_date = date + delay in
+            let completion_date = date + issue_cycles + delay - 1 in
             if son.date < completion_date then son.date <- completion_date;
             son.emitted_ancestors <- son.emitted_ancestors + 1;
             if son.emitted_ancestors = son.ancestors then
               new_queue := son :: !new_queue)
           node.sons;
-        let issue_cycles = self#instr_issue_cycles node.instr in
         instr_cons node.instr.desc node.instr.arg node.instr.res
           (self#reschedule !new_queue (date + issue_cycles) cont)
   end
diff --git a/asmrun/alpha.S b/asmrun/alpha.S
index 52a90650c..c71edd762 100644
--- a/asmrun/alpha.S
+++ b/asmrun/alpha.S
@@ -59,8 +59,8 @@
         stt     $f25, 25 * 8 ($24); \
         stt     $f26, 26 * 8 ($24); \
         stt     $f27, 27 * 8 ($24); \
-        stt     $f28, 28 * 8 ($24); \
-        stt     $f29, 29 * 8 ($24)
+        stt     $f29, 29 * 8 ($24); \
+        stt     $f30, 30 * 8 ($24)
 
 #define LOAD_ALL_REGS \
         lda     $24, gc_entry_regs; \
@@ -105,8 +105,8 @@
         ldt     $f25, 25 * 8 ($24); \
         ldt     $f26, 26 * 8 ($24); \
         ldt     $f27, 27 * 8 ($24); \
-        ldt     $f28, 28 * 8 ($24); \
-        ldt     $f29, 29 * 8 ($24)
+        ldt     $f29, 29 * 8 ($24); \
+        ldt     $f30, 30 * 8 ($24)
 
 /* Allocation */
 
@@ -424,12 +424,16 @@ callback3:
         .ent    call_array_bound_error
         .align  3
 call_array_bound_error:
-        br      $27, $109
-$109:   ldgp    $gp, 0($27)
+        br      $27, $111
+$111:   ldgp    $gp, 0($27)
         jsr     array_bound_error       /* never returns */
         .end    call_array_bound_error
 
+#ifdef SYS_digital	
         .rdata
+#else
+        .section .rodata
+#endif
         .globl  system_frametable
 system_frametable:
         .quad   1               /* one descriptor */
diff --git a/configure b/configure
index 01dcbe18a..f38d65328 100755
--- a/configure
+++ b/configure
@@ -207,7 +207,8 @@ model=default
 system=unknown
 
 case "$host" in
-  alpha-*-osf*)                 arch=alpha;;
+  alpha-*-osf*)                 arch=alpha; system=digital;;
+  alpha-*-linux*)               arch=alpha; system=linux;;
   sparc-*-sunos4.*)             arch=sparc; system=sunos;;
   sparc-*-solaris2.*)           arch=sparc; system=solaris;;
   sparc-*-*bsd*)                arch=sparc; system=bsd;;
@@ -227,8 +228,9 @@ case "$host" in
   m68k-*-sunos*)                arch=m68k; system=sunos;;
 esac
 
-case "$arch" in
-  alpha|mips) nativecc=cc;;
+case "$arch,$system" in
+  alpha,digital) nativecc=cc;;
+  mips,*) nativecc=cc;;
   *) nativecc="$bytecc";;
 esac
 
@@ -236,13 +238,13 @@ nativecccompopts=''
 nativecclinkopts=''
 
 case "$arch,$nativecc,$system" in
-  alpha,cc,*)     nativecccompopts=-std1;;
-  mips,cc,irix)   nativecccompopts=-32
-                  nativecclinkopts="-32 -Wl,-woff,84";;
-  mips,cc,ultrix) nativecccompopts=-std;;
-  *,*,nextstep)   nativecccompopts="-Wall -U__GNUC__ -posix"
-                  nativecclinkopts="-posix";;
-  *,gcc,*)        nativecccompopts=-Wall;;
+  alpha,cc,digital) nativecccompopts=-std1;;
+  mips,cc,irix)     nativecccompopts=-32
+                    nativecclinkopts="-32 -Wl,-woff,84";;
+  mips,cc,ultrix)   nativecccompopts=-std;;
+  *,*,nextstep)     nativecccompopts="-Wall -U__GNUC__ -posix"
+                    nativecclinkopts="-posix";;
+  *,gcc,*)          nativecccompopts=-Wall;;
 esac
 
 asflags=''
@@ -250,7 +252,8 @@ aspp='$(AS)'
 asppflags=''
 
 case "$arch,$model,$system" in
-  alpha,*,*)        asflags='-O2'; asppflags="$asflags";;
+  alpha,*,digital)  asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)';;
+  alpha,*,linux)    aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
   mips,*,irix)      asflags='-32 -O2'; asppflags="$asflags";;
   mips,*,ultrix)    asflags='-O2'; asppflags="$asflags";;
   sparc,*,bsd)      aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';;
@@ -537,7 +540,7 @@ fi
 
 case "$host" in
   mips-*-ultrix*) bignum_arch=mips;;
-  alpha*) bignum_arch=alpha;;
+  alpha-*-osf*) bignum_arch=alpha;;
   i960*) bignum_arch=i960;;
   sparc-*-sunos*) bignum_arch=supersparc;;
   sparc-*-solaris*) bignum_arch=supersparc-solaris;;