[MLton-commit] r7173
Matthew Fluet
fluet at mlton.org
Thu Jun 18 11:06:37 PDT 2009
There is no artificial limit on heap check ammounts.
----------------------------------------------------------------------
U mlton/trunk/mlton/backend/limit-check.fun
U mlton/trunk/mlton/backend/runtime.fun
U mlton/trunk/mlton/backend/runtime.sig
U mlton/trunk/mlton/control/bits.sml
U mlton/trunk/runtime/platform.c
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/backend/limit-check.fun
===================================================================
--- mlton/trunk/mlton/backend/limit-check.fun 2009-06-18 15:21:52 UTC (rev 7172)
+++ mlton/trunk/mlton/backend/limit-check.fun 2009-06-18 18:06:36 UTC (rev 7173)
@@ -166,7 +166,7 @@
local
val r: Label.t option ref = ref NONE
in
- fun allocTooLarge () =
+ fun heapCheckTooLarge () =
case !r of
SOME l => l
| NONE =>
@@ -185,7 +185,7 @@
readsStackTop = false,
return = Type.unit,
symbolScope = CFunction.SymbolScope.Private,
- target = CFunction.Target.Direct "MLton_allocTooLarge",
+ target = CFunction.Target.Direct "MLton_heapCheckTooLarge",
writesStackTop = false}
val _ =
newBlocks :=
@@ -312,6 +312,12 @@
in
label
end
+ fun gotoHeapCheckTooLarge () =
+ newBlock
+ (true,
+ Vector.new0 (),
+ Transfer.Goto {args = Vector.new0 (),
+ dst = heapCheckTooLarge ()})
fun primApp (prim, op1, op2, {collect, dontCollect}) =
let
val res = Var.newNoname ()
@@ -414,10 +420,22 @@
Operand.Runtime Frontier,
insert (Operand.word
(WordX.zero (WordSize.csize ()))))
- else heapCheck (true,
- Operand.word (WordX.fromIntInf
- (Bytes.toIntInf bytes,
- WordSize.csize ()))))
+ else
+ let
+ val bytes =
+ let
+ val bytes =
+ WordX.fromIntInf
+ (Bytes.toIntInf bytes,
+ WordSize.csize ())
+ in
+ SOME bytes
+ end handle Overflow => NONE
+ in
+ case bytes of
+ NONE => gotoHeapCheckTooLarge ()
+ | SOME bytes => heapCheck (true, Operand.word bytes)
+ end)
fun smallAllocation (): unit =
let
val b = blockCheckAmount {blockIndex = i}
@@ -435,38 +453,42 @@
(case c of
Const.Word w =>
heapCheckNonZero
- (Bytes.fromWord
- (Word.addCheck
- (Word.fromIntInf (WordX.toIntInf w),
- Bytes.toWord extraBytes))
- handle Overflow => Runtime.allocTooLarge)
- | _ => Error.bug "LimitCheck.bigAllocation: strange primitive bytes needed")
+ (Bytes.+
+ (Bytes.fromIntInf (WordX.toIntInf w),
+ extraBytes))
+ | _ => Error.bug "LimitCheck.bigAllocation: strange constant bytesNeeded")
| _ =>
let
val bytes = Var.newNoname ()
- val _ =
- newBlock
- (true,
- Vector.new0 (),
- Transfer.Arith
- {args = Vector.new2 (Operand.word
- (WordX.fromIntInf
- (Word.toIntInf
- (Bytes.toWord extraBytes),
- WordSize.csize ())),
- bytesNeeded),
- dst = bytes,
- overflow = allocTooLarge (),
- prim = Prim.wordAddCheck (WordSize.csize (),
- {signed = false}),
- success = (heapCheck
- (false,
- Operand.Var
- {var = bytes,
- ty = Type.csize ()})),
- ty = Type.csize ()})
+ val extraBytes =
+ let
+ val extraBytes =
+ WordX.fromIntInf
+ (Bytes.toIntInf extraBytes,
+ WordSize.csize ())
+ in
+ SOME extraBytes
+ end handle Overflow => NONE
in
- ()
+ case extraBytes of
+ NONE => ignore (gotoHeapCheckTooLarge ())
+ | SOME extraBytes =>
+ (ignore o newBlock)
+ (true,
+ Vector.new0 (),
+ Transfer.Arith
+ {args = Vector.new2 (Operand.word extraBytes,
+ bytesNeeded),
+ dst = bytes,
+ overflow = heapCheckTooLarge (),
+ prim = Prim.wordAddCheck (WordSize.csize (),
+ {signed = false}),
+ success = (heapCheck
+ (false,
+ Operand.Var
+ {var = bytes,
+ ty = Type.csize ()})),
+ ty = Type.csize ()})
end
end
in
Modified: mlton/trunk/mlton/backend/runtime.fun
===================================================================
--- mlton/trunk/mlton/backend/runtime.fun 2009-06-18 15:21:52 UTC (rev 7172)
+++ mlton/trunk/mlton/backend/runtime.fun 2009-06-18 18:06:36 UTC (rev 7173)
@@ -208,9 +208,6 @@
Promise.lazy (Bits.toBytes o Control.Target.Size.cpointer)
val labelSize = cpointerSize
-(* See platform.c. *)
-val allocTooLarge = Bytes.fromIntInf (IntInf.<< (1, 0w30))
-
(* See gc/heap.h. *)
val limitSlop = Bytes.fromInt 512
Modified: mlton/trunk/mlton/backend/runtime.sig
===================================================================
--- mlton/trunk/mlton/backend/runtime.sig 2009-06-18 15:21:52 UTC (rev 7172)
+++ mlton/trunk/mlton/backend/runtime.sig 2009-06-18 18:06:36 UTC (rev 7173)
@@ -76,7 +76,6 @@
| Weak of {gone: bool}
end
- val allocTooLarge: Bytes.t
val arrayLengthOffset: unit -> Bytes.t
val arrayLengthSize: unit -> Bytes.t
val headerOffset: unit -> Bytes.t
Modified: mlton/trunk/mlton/control/bits.sml
===================================================================
--- mlton/trunk/mlton/control/bits.sml 2009-06-18 15:21:52 UTC (rev 7172)
+++ mlton/trunk/mlton/control/bits.sml 2009-06-18 18:06:36 UTC (rev 7173)
@@ -76,7 +76,6 @@
val equals: t * t -> bool
val fromInt: int -> t
val fromIntInf: IntInf.t -> t
- val fromWord: word -> t
(* val inWord8: t *)
(* val inWord16: t *)
val inWord32: t
@@ -93,7 +92,6 @@
val toInt: t -> int
val toIntInf: t -> IntInf.t
val toString: t -> string
- val toWord: t -> word
val zero: t
end
@@ -157,8 +155,6 @@
val inWord32: bytes = 4
val inWord64: bytes = 8
- val fromWord = Word.toIntInf
-
fun isAligned (b, {alignment = a}) = 0 = rem (b, a)
(* fun isWord8Aligned b = isAligned (b, {alignment = inWord8}) *)
(* fun isWord16Aligned b = isAligned (b, {alignment = inWord16}) *)
@@ -167,8 +163,6 @@
fun toBits b = b * Bits.inByte
- val toWord = Word.fromIntInf
-
val align = align
(* val alignDown = alignDown *)
(* fun alignWord8 b = align (b, {alignment = inWord8}) *)
Modified: mlton/trunk/runtime/platform.c
===================================================================
--- mlton/trunk/runtime/platform.c 2009-06-18 15:21:52 UTC (rev 7172)
+++ mlton/trunk/runtime/platform.c 2009-06-18 18:06:36 UTC (rev 7173)
@@ -30,8 +30,7 @@
exit (status);
}
-void MLton_allocTooLarge (void) {
- fprintf (stderr, "Out of memory: attempt to allocate more than %"PRIuMAX" bytes.\n",
- (uintmax_t)0x7FFFFFFF);
- exit (2);
+void MLton_heapCheckTooLarge (void) {
+ die ("Out of memory. Unable to check heap for more than %"PRIuMAX" bytes.\n",
+ (uintmax_t)SIZE_MAX);
}
More information about the MLton-commit
mailing list