[MLton-commit] r4688

Stephen Weeks MLton@mlton.org
Mon, 17 Jul 2006 18:33:05 -0700


Fixed bug on platforms that require 64-bit words to be double word
aligned (e.g. Sparc).  Fixed bug on HPPA -- it needs to handle
misaligned reals and words.  Both of these bugs were likely not seen
because they only show up when compiling with -align 4, and the
default on both HPPA and Sparc is -align 8.

Here's a simple program that demonstrates the bug.

  val ws: Word64.word list = List.tabulate (10, Word64.fromInt)
  val () = List.app (fn w => print (concat [Word64.toString w, "\n"])) ws


----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
U   mlton/branches/on-20050822-x86_64-branch/mlton/codegen/c-codegen/c-codegen.fun
U   mlton/branches/on-20050822-x86_64-branch/runtime/basis/Word/Word-ops.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml	2006-07-18 01:31:18 UTC (rev 4687)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library/primitive/basis-ffi.sml	2006-07-18 01:33:00 UTC (rev 4688)
@@ -1225,12 +1225,15 @@
 val add = _import "Word64_add" : Word64.t * Word64.t -> Word64.t;
 val andb = _import "Word64_andb" : Word64.t * Word64.t -> Word64.t;
 val equal = _import "Word64_equal" : Word64.t * Word64.t -> Bool.t;
+val fetch = _import "Word64_fetch" : (Word64.t) ref -> Word64.t;
 val lshift = _import "Word64_lshift" : Word64.t * Word32.t -> Word64.t;
+val move = _import "Word64_move" : (Word64.t) ref * (Word64.t) ref -> unit;
 val neg = _import "Word64_neg" : Word64.t -> Word64.t;
 val notb = _import "Word64_notb" : Word64.t -> Word64.t;
 val orb = _import "Word64_orb" : Word64.t * Word64.t -> Word64.t;
 val rol = _import "Word64_rol" : Word64.t * Word32.t -> Word64.t;
 val ror = _import "Word64_ror" : Word64.t * Word32.t -> Word64.t;
+val store = _import "Word64_store" : (Word64.t) ref * Word64.t -> unit;
 val sub = _import "Word64_sub" : Word64.t * Word64.t -> Word64.t;
 val xorb = _import "Word64_xorb" : Word64.t * Word64.t -> Word64.t;
 end

Modified: mlton/branches/on-20050822-x86_64-branch/mlton/codegen/c-codegen/c-codegen.fun
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/mlton/codegen/c-codegen/c-codegen.fun	2006-07-18 01:31:18 UTC (rev 4687)
+++ mlton/branches/on-20050822-x86_64-branch/mlton/codegen/c-codegen/c-codegen.fun	2006-07-18 01:33:00 UTC (rev 4688)
@@ -579,30 +579,42 @@
                then s
             else concat [s, " /* ", Label.toString l, " */"]
          end
-      val handleMisalignedReals =
+      val handleMisaligned =
          let
             open Control
          in
-            !align = Align4 andalso !targetArch = Sparc
+            !align = Align4
+            andalso (case !targetArch of
+                        HPPA => true
+                      | Sparc => true
+                      | _ => false)
          end
+      val handleMisaligned =
+         fn ty =>
+         handleMisaligned
+         andalso (Type.equals (ty, Type.real R64)
+                  orelse Type.equals (ty, Type.word (Bits.fromInt 64)))
       fun addr z = concat ["&(", z, ")"]
-      fun realFetch z = concat ["Real64_fetch(", addr z, ")"]
-      fun realMove {dst, src} =
-         concat ["Real64_move(", addr dst, ", ", addr src, ");\n"]
-      fun realStore {dst, src} =
-         concat ["Real64_store(", addr dst, ", ", src, ");\n"]
+      fun fetch (z, ty) =
+         concat [CType.toString (Type.toCType ty),
+                 "_fetch(", addr z, ")"]
+      fun move' ({dst, src}, ty) =
+         concat [CType.toString (Type.toCType ty),
+                 "_move(", addr dst, ", ", addr src, ");\n"]
+      fun store ({dst, src}, ty) =
+         concat [CType.toString (Type.toCType ty),
+                 "_store(", addr dst, ", ", src, ");\n"]
       fun move {dst: string, dstIsMem: bool,
                 src: string, srcIsMem: bool,
                 ty: Type.t}: string =
-         if handleMisalignedReals
-            andalso Type.equals (ty, Type.real R64)
-            then
-               case (dstIsMem, srcIsMem) of
-                  (false, false) => concat [dst, " = ", src, ";\n"]
-                | (false, true) => concat [dst, " = ", realFetch src, ";\n"]
-                | (true, false) => realStore {dst = dst, src = src}
-                | (true, true) => realMove {dst = dst, src = src}
-         else concat [dst, " = ", src, ";\n"]
+         if handleMisaligned ty then
+            case (dstIsMem, srcIsMem) of
+               (false, false) => concat [dst, " = ", src, ";\n"]
+             | (false, true) => concat [dst, " = ", fetch (src, ty), ";\n"]
+             | (true, false) => store ({dst = dst, src = src}, ty)
+             | (true, true) => move' ({dst = dst, src = src}, ty)
+         else
+            concat [dst, " = ", src, ";\n"]
       local
          datatype z = datatype Operand.t
          fun toString (z: Operand.t): string =
@@ -641,11 +653,10 @@
          val operandToString = toString
       end
       fun fetchOperand (z: Operand.t): string =
-         if handleMisalignedReals
-            andalso Type.equals (Operand.ty z, Type.real R64)
-            andalso Operand.isMem z
-            then realFetch (operandToString z)
-         else operandToString z
+         if handleMisaligned (Operand.ty z) andalso Operand.isMem z then
+            fetch (operandToString z, Operand.ty z)
+         else
+            operandToString z
       fun outputStatement (s, print) =
          let
             datatype z = datatype Statement.t

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/basis/Word/Word-ops.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/basis/Word/Word-ops.h	2006-07-18 01:31:18 UTC (rev 4687)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/basis/Word/Word-ops.h	2006-07-18 01:33:00 UTC (rev 4688)
@@ -47,6 +47,40 @@
     return op w;                                                        \
   }
 
+#define misaligned(size)                                                \
+  typedef volatile union {                                              \
+    Word##size##_t r;                                                   \
+    Word32_t ws[sizeof(Word##size##_t) / sizeof(Word32_t)];             \
+  } Word##size##OrWord32s;                                              \
+  MLTON_CODEGEN_STATIC_INLINE                                           \
+  Word##size##_t Word##size##_fetch (Ref(Word##size##_t) rp) {          \
+    Word##size##OrWord32s u;                                            \
+    Word32_t *wp;                                                       \
+    wp = (Word32_t*)rp;                                                 \
+    u.ws[0] = wp[0];                                                    \
+    if ((sizeof(Word##size##_t) / sizeof(Word32_t)) > 1)                \
+      u.ws[1] = wp[1];                                                  \
+    return u.r;                                                         \
+  }                                                                     \
+  MLTON_CODEGEN_STATIC_INLINE                                           \
+  void Word##size##_store (Ref(Word##size##_t) rp, Word##size##_t r) {  \
+    Word##size##OrWord32s u;                                            \
+    Word32_t *wp;                                                       \
+    wp = (Word32_t*)rp;                                                 \
+    u.r = r;                                                            \
+    wp[0] = u.ws[0];                                                    \
+    if ((sizeof(Word##size##_t) / sizeof(Word32_t)) > 1)                \
+      wp[1] = u.ws[1];                                                  \
+    return;                                                             \
+  }                                                                     \
+  MLTON_CODEGEN_STATIC_INLINE                                           \
+  void Word##size##_move (Ref(Word##size##_t) dst, Ref(Word##size##_t) src) { \
+    Word##size##_t r;                                                   \
+    r = Word##size##_fetch (src);                                       \
+    Word##size##_store (dst, r);                                        \
+    return;                                                             \
+  }
+
 #define all(size)                               \
 binary (size, add, +)                           \
 binary (size, andb, &)                          \
@@ -79,17 +113,20 @@
 shift (S##size, rshift, >>)                     \
 shift (U##size, rshift, >>)                     \
 binary (size, sub, -)                           \
-binary (size, xorb, ^)                          \
+binary (size, xorb, ^)
 
 all (8)
 all (16)
 all (32)
 all (64)
 
+misaligned(64)
+
+#undef all
 #undef binary
 #undef bothBinary
+#undef bothCompare
 #undef compare
-#undef bothCompare
+#undef misaligned
+#undef shift
 #undef unary
-#undef shift
-#undef all

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def	2006-07-18 01:31:18 UTC (rev 4687)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gen/basis-ffi.def	2006-07-18 01:33:00 UTC (rev 4688)
@@ -997,12 +997,15 @@
 Word64.add = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Word64.t
 Word64.andb = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Word64.t
 Word64.equal = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Bool.t
+Word64.fetch = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t ref -> Word64.t
 Word64.lshift = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word32.t -> Word64.t
+Word64.move = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t ref * Word64.t ref -> unit
 Word64.neg = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t -> Word64.t
 Word64.notb = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t -> Word64.t
 Word64.orb = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Word64.t
 Word64.rol = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word32.t -> Word64.t
 Word64.ror = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word32.t -> Word64.t
+Word64.store = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t ref * Word64.t -> unit
 Word64.sub = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Word64.t
 Word64.xorb = _import MLTON_CODEGEN_STATIC_INLINE : Word64.t * Word64.t -> Word64.t
 WordS8.addCheckOverflows = _import MLTON_CODEGEN_STATIC_INLINE : Int8.t * Int8.t -> Bool.t