You can subscribe to this list here.
2005 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
(56) |
Sep
(40) |
Oct
(30) |
Nov
(144) |
Dec
(23) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2006 |
Jan
(41) |
Feb
(29) |
Mar
(31) |
Apr
(39) |
May
(193) |
Jun
(45) |
Jul
(19) |
Aug
(3) |
Sep
(23) |
Oct
(83) |
Nov
(92) |
Dec
(123) |
2007 |
Jan
(90) |
Feb
(267) |
Mar
(120) |
Apr
(51) |
May
(40) |
Jun
(121) |
Jul
(109) |
Aug
(173) |
Sep
(77) |
Oct
(52) |
Nov
(121) |
Dec
(62) |
2008 |
Jan
(76) |
Feb
(53) |
Mar
(98) |
Apr
(87) |
May
(26) |
Jun
(27) |
Jul
(23) |
Aug
(136) |
Sep
(79) |
Oct
(68) |
Nov
(29) |
Dec
(14) |
2009 |
Jan
(7) |
Feb
(2) |
Mar
(11) |
Apr
(75) |
May
(1) |
Jun
(95) |
Jul
(19) |
Aug
(4) |
Sep
(8) |
Oct
(93) |
Nov
(43) |
Dec
(21) |
2010 |
Jan
(20) |
Feb
(23) |
Mar
(18) |
Apr
(6) |
May
(20) |
Jun
(23) |
Jul
(1) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
2011 |
Jan
(2) |
Feb
(6) |
Mar
(15) |
Apr
(5) |
May
(9) |
Jun
(14) |
Jul
(9) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
2012 |
Jan
|
Feb
(3) |
Mar
|
Apr
|
May
(2) |
Jun
(17) |
Jul
(37) |
Aug
|
Sep
(1) |
Oct
(6) |
Nov
|
Dec
|
2013 |
Jan
|
Feb
|
Mar
(5) |
Apr
(2) |
May
(7) |
Jun
(11) |
Jul
(8) |
Aug
|
Sep
(1) |
Oct
(2) |
Nov
|
Dec
|
2014 |
Jan
|
Feb
(2) |
Mar
(1) |
Apr
|
May
(1) |
Jun
(1) |
Jul
(7) |
Aug
(2) |
Sep
|
Oct
(5) |
Nov
(2) |
Dec
(4) |
2015 |
Jan
|
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(9) |
Jul
(1) |
Aug
|
Sep
|
Oct
(4) |
Nov
(1) |
Dec
|
2016 |
Jan
(2) |
Feb
(1) |
Mar
(1) |
Apr
(1) |
May
(1) |
Jun
(2) |
Jul
(1) |
Aug
|
Sep
(5) |
Oct
|
Nov
|
Dec
|
2017 |
Jan
(1) |
Feb
(3) |
Mar
(3) |
Apr
(7) |
May
(2) |
Jun
(2) |
Jul
(5) |
Aug
(1) |
Sep
(2) |
Oct
(17) |
Nov
(4) |
Dec
(7) |
2018 |
Jan
(5) |
Feb
(14) |
Mar
(2) |
Apr
(5) |
May
(2) |
Jun
(5) |
Jul
|
Aug
(2) |
Sep
|
Oct
(3) |
Nov
(5) |
Dec
|
2019 |
Jan
(4) |
Feb
(2) |
Mar
(3) |
Apr
(1) |
May
(8) |
Jun
(14) |
Jul
(2) |
Aug
|
Sep
(2) |
Oct
(2) |
Nov
(15) |
Dec
(2) |
2020 |
Jan
(10) |
Feb
(3) |
Mar
(1) |
Apr
|
May
(9) |
Jun
(4) |
Jul
(16) |
Aug
(10) |
Sep
(4) |
Oct
(3) |
Nov
|
Dec
|
2021 |
Jan
(11) |
Feb
(2) |
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
(5) |
Sep
|
Oct
(6) |
Nov
(4) |
Dec
(4) |
2022 |
Jan
(4) |
Feb
(2) |
Mar
(2) |
Apr
|
May
(6) |
Jun
(3) |
Jul
|
Aug
(1) |
Sep
|
Oct
|
Nov
(1) |
Dec
|
2023 |
Jan
|
Feb
|
Mar
|
Apr
(2) |
May
(5) |
Jun
(1) |
Jul
(4) |
Aug
(1) |
Sep
|
Oct
(1) |
Nov
(13) |
Dec
|
2024 |
Jan
(1) |
Feb
|
Mar
(5) |
Apr
|
May
(10) |
Jun
|
Jul
|
Aug
(3) |
Sep
|
Oct
|
Nov
(1) |
Dec
(14) |
2025 |
Jan
(3) |
Feb
|
Mar
(1) |
Apr
|
May
(2) |
Jun
(3) |
Jul
|
Aug
|
Sep
(2) |
Oct
(2) |
Nov
|
Dec
|
S | M | T | W | T | F | S |
---|---|---|---|---|---|---|
|
|
|
|
|
1
|
2
|
3
|
4
(11) |
5
(5) |
6
(2) |
7
(1) |
8
|
9
(2) |
10
|
11
|
12
(1) |
13
(9) |
14
(10) |
15
(1) |
16
|
17
|
18
|
19
|
20
|
21
|
22
|
23
(1) |
24
|
25
|
26
(6) |
27
|
28
|
29
(4) |
|
From: Vesa K. <ve...@ml...> - 2008-02-29 09:04:24
|
Updated copyright. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml U mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml 2008-02-29 17:01:58 UTC (rev 6423) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml 2008-02-29 17:04:22 UTC (rev 6424) @@ -1,4 +1,4 @@ -(* Copyright (C) 2006-2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2006-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig 2008-02-29 17:01:58 UTC (rev 6423) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig 2008-02-29 17:04:22 UTC (rev 6424) @@ -1,4 +1,4 @@ -(* Copyright (C) 2006-2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2006-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. |
From: Vesa K. <ve...@ml...> - 2008-02-29 09:01:59
|
Added experimental dependent product combinator for fixed point witnesses. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml U mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml 2008-02-29 16:55:50 UTC (rev 6422) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/generic/tie.sml 2008-02-29 17:01:58 UTC (rev 6423) @@ -18,13 +18,14 @@ in (b2a b, Fn.map iso fB) end - fun op *` (aT, bT) () () = let + fun product (aT, a2bT) () () = let val (a, fA) = aT () () - val (b, fB) = bT () () + val (b, fB) = a2bT a () () in (a & b, Product.map (fA, fB)) end (* The rest are not primitive operations. *) + fun op *` (aT, bT) = product (aT, Fn.const bT) fun tuple2 ab = iso (op *` ab) Product.isoTuple2 fun tier th = pure ((fn (a, ua) => (a, Fn.const a o ua)) o th) fun id x = pure (Fn.const (x, Fn.id)) Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig 2008-02-29 16:55:50 UTC (rev 6422) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/generic/tie.sig 2008-02-29 17:01:58 UTC (rev 6423) @@ -66,12 +66,17 @@ * a witness. *) - val *` : 'a t * 'b t -> ('a, 'b) Product.t t + val product : 'a t * ('a -> 'b t) -> ('a, 'b) Product.t t (** - * Given witnesses for {'a} and {'b} produces a witness for the product - * {('a, 'b) Product.t}. This is used when mutual recursion is needed. + * Dependent product combinator. Given a witness for {'a} and a + * constructor from a {'a} to witness for {'b}, produces a witness for + * the product {('a, 'b) Product.t}. The constructor for {'b} should + * not access the (proxy) value {'a} before it has been fixed. *) + val *` : 'a t * 'b t -> ('a, 'b) Product.t t + (** {a *` b} is equivalent to {product (a, const b)}. *) + val tuple2 : 'a t * 'b t -> ('a * 'b) t (** * Given witnesses for {'a} and {'b} produces a witness for the product |
From: Vesa K. <ve...@ml...> - 2008-02-29 08:55:51
|
Made the Void.t type degenerate. Now, even if the would be left concrete, it would still be impossible to generate values of the type. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2008-02-29 16:52:38 UTC (rev 6421) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/bootstrap.sml 2008-02-29 16:55:50 UTC (rev 6422) @@ -6,7 +6,7 @@ (* Minimal modules for bootstrapping. *) -structure Void = struct abstype t = T with fun void T = void T end end +structure Void = struct abstype t = T of t with fun void t = void t end end structure Exn = struct type t = exn end structure Fn = struct type ('a, 'b) t = 'a -> 'b end structure Unit = struct type t = unit fun compare ((), ()) = EQUAL end |
From: Vesa K. <ve...@ml...> - 2008-02-29 08:52:45
|
Added an initial implementation of a generic value enumeration. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm A mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb U mltonlib/trunk/com/ssh/generic/unstable/lib.use U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml A mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig A mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-29 16:52:38 UTC (rev 6421) @@ -26,6 +26,7 @@ ../../../public/value/arbitrary.sig ../../../public/value/data-rec-info.sig ../../../public/value/dynamic.sig + ../../../public/value/enum.sig ../../../public/value/eq.sig ../../../public/value/fmap.sig ../../../public/value/hash.sig Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-29 16:52:38 UTC (rev 6421) @@ -28,6 +28,7 @@ ../../value/data-rec-info.sml ../../value/debug.sml ../../value/dynamic.sml + ../../value/enum.sml ../../value/eq.sml ../../value/fmap.sml ../../value/hash.sml Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml 2008-02-29 16:52:38 UTC (rev 6421) @@ -0,0 +1,164 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +functor WithEnum (Arg : WITH_ENUM_DOM) = let + structure Result = struct + (* <-- SML/NJ workaround *) + open TopLevel + infix 4 <\ + infix 0 & + (* SML/NJ workaround --> *) + + infixr ::: + + structure Enum = struct + datatype 'a t = IN of Unit.t -> ('a * 'a t) Option.t + fun get (IN t) = t () + val empty = IN (fn () => NONE) +(* + fun takeAtMost (e, n) = + IN (fn () => + if n <= 0 + then NONE + else case get e + of NONE => NONE + | SOME (x, e) => SOME (x, takeAtMost (e, n-1))) + fun toList e = let + fun lp (xs, e) = + case get e + of NONE => rev xs + | SOME (x, e) => lp (x::xs, e) + in + lp ([], e) + end +*) + fun interleave (xs, ys) = + IN (fn () => + case get xs + of NONE => get ys + | SOME (x, xs) => SOME (x, interleave (ys, xs))) +(* + fun iterate f x = + IN (fn () => SOME (x, iterate f (f x))) +*) + fun iterateUnless f x = + IN (fn () => SOME (x, iterateUnless f (f x) handle _ => empty)) + fun map f xs = + IN (fn () => + case get xs + of NONE => NONE + | SOME (x, xs) => SOME (f x, map f xs)) + fun nonEmptyTails xs = + IN (fn () => + case get xs + of NONE => NONE + | SOME (_, xs') => SOME (xs, nonEmptyTails xs')) + fun x ::: xs = IN (fn () => SOME (x, xs)) + end + + open Enum + + fun iso' b (_, b2a) = map b2a b + + fun product (xs, ys) = let + fun lp zss = + IN (fn () => + case get zss + of NONE => NONE + | SOME (zs, zss) => get (interleave (zs, lp zss))) + in + lp (map (fn xs => map (fn y => #1 (valOf (get xs)) & y) ys) + (nonEmptyTails xs)) + end + + fun list' a = + IN (fn () => get (interleave ([]:::empty, + map (fn x & xs => x::xs) + (product (a, list' a))))) + + fun mkInt zero one ~ op + = + interleave (iterateUnless ( one <\ op +) zero, + iterateUnless (~one <\ op +) (~one)) + + fun mkWord one op + (min, max) = + iterateUnless (fn w => if w = max then raise Overflow else w + one) + min + + fun mkReal zero posInf ~ nextAfter = + interleave (iterateUnless (fn r => nextAfter (r, posInf)) zero, + iterateUnless (fn r => nextAfter (r, ~posInf)) (~zero)) + + structure EnumRep = LayerRep (open Arg structure Rep = MkClosedRep (Enum)) + + open EnumRep.This + + val enum = getT + + structure Open = LayerDepCases + (fun iso bT = iso' (getT bT) + fun isoProduct bP = iso' (getP bP) + fun isoSum bS = iso' (getS bS) + + fun op *` (xs, ys) = product (getP xs, getP ys) + val T = getT + fun R _ = getT + val tuple = getP + val record = getP + + fun op +` (aS, bS) = let + val a = map INL (getS aS) + val b = map INR (getS bS) + in + interleave (if Arg.hasBaseCase aS then (a, b) else (b, a)) + end + val unit = ():::empty + fun C0 _ = unit + fun C1 _ = getT + val data = getS + + fun Y ? = Tie.iso Tie.function (fn IN ? => ?, IN) ? + + fun op --> _ = empty (* XXX: not yet implemented *) + + val exn = empty (* XXX: not yet implemented *) + fun regExn0 _ _ = () + fun regExn1 _ _ _ = () + + fun list a = list' (getT a) + fun vector a = iso' (list a) Vector.isoList + + fun array a = iso' (list a) Array.isoList + fun refc a = iso a (undefined, ref) + + val fixedInt = mkInt 0 1 ~ FixedInt.+ + val largeInt = mkInt 0 1 ~ LargeInt.+ + + val largeReal = mkReal 0.0 LargeReal.posInf ~ LargeReal.nextAfter + val largeWord = mkWord 0w1 op + LargeWord.bounds + + val bool = false:::true:::empty + val char = iterateUnless (chr o 1 <\ op + o ord) Char.minValue + val int = mkInt 0 1 ~ Int.+ + val real = mkReal 0.0 Real.posInf ~ Real.nextAfter + val string = iso' (list' char) String.isoList + val word = mkWord 0w1 op + Word.bounds + + val word8 = mkWord 0w1 op + Word8.bounds + val word32 = mkWord 0w1 op + Word32.bounds +(* + val word64 = mkWord 0w1 op + Word64.bounds +*) + + fun hole () = IN undefined + + open Arg EnumRep) + end +in + Result :> ENUM_CASES + where type ('a, 'x) Open.Rep.t = ('a, 'x) Result.Open.Rep.t + where type ('a, 'x) Open.Rep.s = ('a, 'x) Result.Open.Rep.s + where type ('a, 'k, 'x) Open.Rep.p = ('a, 'k, 'x) Result.Open.Rep.p +end Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/enum.sml ___________________________________________________________________ Name: svn:eol-style + native Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-29 16:52:38 UTC (rev 6421) @@ -1,4 +1,4 @@ -(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. @@ -86,6 +86,9 @@ public/value/dynamic.sig detail/value/dynamic.sml + public/value/enum.sig + detail/value/enum.sml + public/value/eq.sig detail/value/eq.sml Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.use =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-29 16:52:38 UTC (rev 6421) @@ -51,6 +51,8 @@ "detail/value/debug.sml", "public/value/dynamic.sig", "detail/value/dynamic.sml", + "public/value/enum.sig", + "detail/value/enum.sml", "public/value/eq.sig", "detail/value/eq.sml", "public/value/fmap.sig", Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-29 16:52:38 UTC (rev 6421) @@ -144,6 +144,10 @@ and WITH_DYNAMIC_DOM = WITH_DYNAMIC_DOM functor WithDynamic (Arg : WITH_DYNAMIC_DOM) : DYNAMIC_CASES = WithDynamic (Arg) +signature ENUM = ENUM and ENUM_CASES = ENUM_CASES + and WITH_ENUM_DOM = WITH_ENUM_DOM +functor WithEnum (Arg : WITH_ENUM_DOM) : ENUM_CASES = WithEnum (Arg) + signature EQ = EQ and EQ_CASES = EQ_CASES and WITH_EQ_DOM = WITH_EQ_DOM functor WithEq (Arg : WITH_EQ_DOM) : EQ_CASES = WithEq (Arg) Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig 2008-02-29 16:52:38 UTC (rev 6421) @@ -0,0 +1,41 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +(** + * Signature for a generic value enumeration. + * + * The main application of enumeration is testing. + *) +signature ENUM = sig + structure EnumRep : OPEN_REP + + structure Enum : sig + type 'a t + (** Type of enumeration streams. *) + + val get : ('a, 'a t) Reader.t + (** + * Reader for enumeration streams. + * + * Enumeration streams are not memoized. Each time {Enum.get} is + * called, a new value is created and all mutable substructures + * generated from an enumeration will be distinct. + *) + end + + val enum : ('a, 'x) EnumRep.t -> 'a Enum.t + (** + * Returns a stream that enumerates through finite, acyclic values of + * the type. + *) +end + +signature ENUM_CASES = sig + include CASES ENUM + sharing Open.Rep = EnumRep +end + +signature WITH_ENUM_DOM = TYPE_INFO_CASES Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/enum.sig ___________________________________________________________________ Name: svn:eol-style + native Added: mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml 2008-02-26 18:28:21 UTC (rev 6420) +++ mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml 2008-02-29 16:52:38 UTC (rev 6421) @@ -0,0 +1,19 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +signature Generic = sig + include Generic ENUM +end + +functor MkGeneric (Arg : Generic) = struct + structure Open = MkGeneric (Arg) + open Arg Open + structure EnumRep = Open.Rep +end + +structure Generic = + MkGeneric (structure Open = WithEnum (Generic) + open Generic Open) Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/enum.sml ___________________________________________________________________ Name: svn:eol-style + native |
From: Vesa K. <ve...@ml...> - 2008-02-26 10:28:22
|
Forgot to export the Contract : CONTRACT module earlier. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2008-02-26 17:18:35 UTC (rev 6419) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/export/common.sml 2008-02-26 18:28:21 UTC (rev 6420) @@ -65,6 +65,7 @@ signature BUFFER = BUFFER signature CHAR = CHAR signature CMP = CMP +signature CONTRACT = CONTRACT signature CPS = CPS signature CVT = CVT signature EFFECT = EFFECT @@ -153,6 +154,7 @@ structure CharVector : MONO_VECTOR = CharVector structure CharVectorSlice : MONO_VECTOR_SLICE = CharVectorSlice structure Cmp : CMP = Cmp +structure Contract : CONTRACT = Contract structure Cvt : CVT = Cvt structure Effect : EFFECT = Effect structure Emb : EMB = Emb |
From: Vesa K. <ve...@ml...> - 2008-02-26 09:18:37
|
Initial implementation of basic Uniplate-style generics. Tested briefly interactively, but not very thoroughly. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm A mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb U mltonlib/trunk/com/ssh/generic/unstable/lib.use U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml A mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig A mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/sigs.cm 2008-02-26 17:18:35 UTC (rev 6419) @@ -1,4 +1,4 @@ -(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. @@ -42,6 +42,7 @@ ../../../public/value/type-exp.sig ../../../public/value/type-hash.sig ../../../public/value/type-info.sig + ../../../public/value/uniplate.sig ../../framework/generics.sml ../../framework/ty.sml ../../util/sml-syntax.sml Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2008-02-26 17:18:35 UTC (rev 6419) @@ -1,4 +1,4 @@ -(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. @@ -44,5 +44,6 @@ ../../value/type-exp.sml ../../value/type-hash.sml ../../value/type-info.sml + ../../value/uniplate.sml extensions.cm sigs.cm Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml 2008-02-26 17:18:35 UTC (rev 6419) @@ -0,0 +1,233 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +(* TBD: Avoid redundantly querying/transforming substructures *) + +functor WithUniplate (Arg : WITH_UNIPLATE_DOM) : UNIPLATE_CASES = struct + (* <-- SML/NJ workaround *) + open TopLevel + infix 7 >> << *` + infix 6 +` + infix 4 orb + infix 0 & + (* SML/NJ workaround --> *) + + type r = Unit.t Ref.t Option.t + type 'a i = r * 'a Univ.Iso.t + + val dummy = (NONE, (undefined, undefined)) + + type e = (HashUniv.t, Unit.t) HashMap.t + type c = Univ.t List.t + datatype 'a t = + IN of 'a i * ((r * e) * c * 'a -> c) * ((r * e) * c * 'a -> 'a * c) + + val none = IN (dummy, fn (_, c, _) => c, fn (_, c, x) => (x, c)) + + fun cyclic aT (IN (_, aKi, aKo)) = let + val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT} + in + IN (dummy, + fn args as ((_, e), c, x) => let + val xD = to x + in + if isSome (HashMap.find e xD) then c + else (HashMap.insert e (xD, ()) ; aKi args) + end, + fn args as ((_, e), c, x) => let + val xD = to x + in + if isSome (HashMap.find e xD) then (x, c) + else (HashMap.insert e (xD, ()) ; aKo args) + end) + end + + fun op `*` (IN (_, aKi, aKo), IN (_, bKi, bKo)) = + IN (dummy, + fn (r, c, a & b) => aKi (r, bKi (r, c, b), a), + fn (r, c, a & b) => + case aKo (r, c, a) + of (a, c) => + case bKo (r, c, b) + of (b, c) => (a & b, c)) + fun op `+` (IN (_, aKi, aKo), IN (_, bKi, bKo)) = + IN (dummy, + fn (r, c, INL a) => aKi (r, c, a) + | (r, c, INR b) => bKi (r, c, b), + fn (r, c, INL a) => Pair.map (INL, id) (aKo (r, c, a)) + | (r, c, INR b) => Pair.map (INR, id) (bKo (r, c, b))) + fun iso' (IN (_, ki, ko)) (a2b, b2a) = + IN (dummy, + fn (r, c, a) => ki (r, c, a2b a), + fn (r, c, a) => Pair.map (b2a, id) (ko (r, c, a2b a))) + + structure UniplateRep = LayerRep + (open Arg + structure Rep = MkClosedRep (type 'a t = 'a t)) + + open UniplateRep.This + + fun newMap () = HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash} + + fun uniplate' aT = + case getT aT + of IN ((NONE, _), _, _) => + (fn x => ([], fn _ => x)) + | IN ((r, (to, from)), ki, ko) => + (fn x => (map from (ki ((r, newMap ()), [], x)), + fn xs => #1 (ko ((r, newMap ()), map to xs, x)))) + + fun children t = #1 o uniplate' t + fun holes t = + (fn (k, c) => let + fun lp hs ys = + fn [] => hs + | x::xs => + lp ((x, fn x => c (List.revAppend (ys, x::xs)))::hs) (x::ys) xs + in + lp [] [] k + end) o + uniplate' t + fun contexts t x = let + fun lp (x, f, ys) = + foldl (fn ((x, c), ys) => lp (x, f o c, ys)) + ((x, f)::ys) + (holes t x) + in + rev (lp (x, id, [])) + end + fun para t f x = f x (map (para t f) (children t x)) + fun descend t f = (fn (k, c) => c (map f k)) o uniplate' t + fun transform t f x = f (descend t (transform t f) x) + fun rewrite t f = + transform t (fn x => case f x of NONE => x | SOME x => rewrite t f x) + fun universe t x = let + fun lp (x, ys) = foldl lp (x::ys) (children t x) + in + rev (lp (x, [])) + end + + fun uniplate t = + (fn (children, context) => + (children, + context o (case length children + of n => fn children => + if n <> length children + then fail "wrong number of children" + else children))) o + uniplate' t + + structure Open = LayerDepCases + (fun iso bT = iso' (getT bT) + fun isoProduct bP = iso' (getP bP) + fun isoSum bS = iso' (getS bS) + + fun op *` (aP, bP) = op `*` (getP aP, getP bP) + val T = getT + fun R _ = getT + val tuple = getP + val record = getP + + fun op +` (aS, bS) = op `+` (getS aS, getS bS) + val unit = none + fun C0 _ = unit + fun C1 _ = getT + val data = getS + + fun Y ? = Tie.pure (fn () => let + val r = SOME (ref ()) + val iso as (to, from) = Univ.Iso.new () + val rKi = ref (raising Fix.Fix) + fun ki' ? = !rKi ? + val rKo = ref (raising Fix.Fix) + fun ko' ? = !rKo ? + val i = (r, iso) + in + (IN (i, + fn args as ((r', _), c, x) => + if r = r' then to x::c else ki' args, + fn args as ((r', _), c, _) => + if r = r' + then case c + of [] => fail "bug" + | x::c => (from x, c) + else ko' args), + fn IN (_, ki, ko) => (rKi := ki ; rKo := ko ; IN (i, ki, ko))) + end) ? + + fun op --> _ = none + + val exn = none + fun regExn0 _ _ = () + fun regExn1 _ _ _ = () + + fun array aT = + case getT aT + of IN (_, aKi, aKo) => + cyclic (Arg.Open.array ignore aT) + (IN (dummy, + fn (r, c, s) => + Array.foldr (fn (a, c) => aKi (r, c, a)) c s, + fn (r, c, s) => let + fun lp i c = + if i = Array.length s + then (s, c) + else case aKo (r, c, Array.sub (s, i)) + of (x, c) => + (Array.update (s, i, x) + ; lp (i+1) c) + in + lp 0 c + end)) + fun list aT = + (Tie.fix Y) + (fn aListT => + iso' (op `+` (unit, op `*` (getT aT, aListT))) + (fn [] => INL () | x::xs => INR (x & xs), + fn INL () => [] | INR (x & xs) => x::xs)) + fun vector aT = + case getT aT + of (IN (_, aKi, aKo)) => + IN (dummy, + fn (r, c, s) => + Vector.foldr (fn (a, c) => aKi (r, c, a)) c s, + fn (r, c, s) => + Vector.unfoldi + (fn (i, c) => aKo (r, c, Vector.sub (s, i))) + (Vector.length s, c)) + + fun refc aT = + case getT aT + of IN (_, aKi, aKo) => + cyclic (Arg.Open.refc ignore aT) + (IN (dummy, + fn (r, c, s) => aKi (r, c, !s), + fn (r, c, s) => case aKo (r, c, !s) + of (x, c) => (s := x ; (s, c)))) + + val fixedInt = none + val largeInt = none + + val largeReal = none + val largeWord = none + + val bool = none + val char = none + val int = none + val real = none + val string = none + val word = none + + val word8 = none + val word32 = none +(* + val word64 = none +*) + + fun hole () = IN (dummy, undefined, undefined) + + open Arg UniplateRep) +end Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml ___________________________________________________________________ Name: svn:eol-style + native Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2008-02-26 17:18:35 UTC (rev 6419) @@ -92,6 +92,9 @@ public/value/fmap.sig detail/value/fmap.sml + public/value/uniplate.sig + detail/value/uniplate.sml + public/value/ord.sig detail/value/ord.sml Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.use =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/lib.use 2008-02-26 17:18:35 UTC (rev 6419) @@ -55,6 +55,8 @@ "detail/value/eq.sml", "public/value/fmap.sig", "detail/value/fmap.sml", + "public/value/uniplate.sig", + "detail/value/uniplate.sml", "public/value/ord.sig", "detail/value/ord.sml", "public/value/pickle.sig", Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2008-02-26 17:18:35 UTC (rev 6419) @@ -1,4 +1,4 @@ -(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland +(* Copyright (C) 2007-2008 SSH Communications Security, Helsinki, Finland * * This code is released under the MLton license, a BSD-style license. * See the LICENSE file or http://mlton.org/License for details. @@ -203,3 +203,8 @@ and WITH_TYPE_HASH_DOM = WITH_TYPE_HASH_DOM functor WithTypeHash (Arg : WITH_TYPE_HASH_DOM) : TYPE_HASH_CASES = WithTypeHash (Arg) + +signature UNIPLATE = UNIPLATE and UNIPLATE_CASES = UNIPLATE_CASES + and WITH_UNIPLATE_DOM = WITH_UNIPLATE_DOM +functor WithUniplate (Arg : WITH_UNIPLATE_DOM) : UNIPLATE_CASES = + WithUniplate (Arg) Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig 2008-02-26 17:18:35 UTC (rev 6419) @@ -0,0 +1,103 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +(** + * Signature for a generic function for processing recursive datatypes. + * Unlike the {Reduce}, {Transform}, and {Fmap} generics, this generic + * allows recursive datatypes to be processed in various ways without + * requiring the recursive datatype to be encoded as a fixed point of a + * functor. + * + * Much of this generic is inspired by the following article: + * + * Uniform Boilerplate and List Processing + * Neil Mitchell and Colin Runciman + * ICFP 2007 + *) +signature UNIPLATE = sig + structure UniplateRep : OPEN_REP + + val children : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t + (** + * Returns all maximal proper substructures of the same type contained + * in the given value. This is non-recursive. + *) + + val universe : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t + (** + * Returns a list of all substructures of the same type contained in + * the given value (including it). This is recursive. + *) + + val holes : ('a, 'x) UniplateRep.t -> 'a -> ('a * 'a UnOp.t) List.t + (** + * Returns a list of all maximal proper substructures of the given + * value and functions to replace the corresponding substructure in the + * given value. + * + *> map op </ (holes t x) = children t x + *) + + val contexts : ('a, 'x) UniplateRep.t -> 'a -> ('a * 'a UnOp.t) List.t + (** + * Returns a list of all substructures of the given value and functions + * to replace the corresponding substructure in the given value. + * + *> map op </ (contexts t x) = universe t x + *) + + val descend : ('a, 'x) UniplateRep.t -> 'a UnOp.t UnOp.t + (** + * Replaces each maximal proper substructure {x} by {f x} in the given + * value. This is non-recursive. + *) + + val para : ('a, 'x) UniplateRep.t -> ('a -> 'b List.t -> 'b) -> 'a -> 'b + (** + * A kind of fold. {para} can be defined as follows: + * + *> fun para t f x = f x (map (para t f) (children t x)) + *) + + val rewrite : ('a, 'x) UniplateRep.t -> ('a -> 'a Option.t) -> 'a UnOp.t + (** + * Exhaustive recursive bottom-up transformation. The idea is to keep + * rewriting as long as some new value is returned. {rewrite} can be + * defined as follows: + * + *> fun rewrite t f = + *> transform t (fn x => case f x + *> of NONE => x + *> | SOME x => rewrite t f x) + *) + + val transform : ('a, 'x) UniplateRep.t -> 'a UnOp.t UnOp.t + (** + * Recursive bottom-up transformation. {transform} can be defined as + * follows: + * + *> fun transform t f x = f (descend t (transform t f) x) + *) + + val uniplate : ('a, 'x) UniplateRep.t -> 'a -> 'a List.t * ('a List.t -> 'a) + (** + * Returns a list of all maximal proper substructures (children) of the + * same type contained in the given value and a function, dubbed + * context, to replace the substructures. At immutable contexts, a new + * value is built. At mutable contexts, the objects are mutated. The + * number of elements in the list given to context must be equal to the + * number of maximal proper substructure returned. All functions + * specified in the {UNIPLATE} signature can be defined in terms of + * {uniplate}. + *) +end + +signature UNIPLATE_CASES = sig + include CASES UNIPLATE + sharing Open.Rep = UniplateRep +end + +signature WITH_UNIPLATE_DOM = HASH_CASES Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/uniplate.sig ___________________________________________________________________ Name: svn:eol-style + native Added: mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml 2008-02-26 17:01:39 UTC (rev 6418) +++ mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml 2008-02-26 17:18:35 UTC (rev 6419) @@ -0,0 +1,19 @@ +(* Copyright (C) 2008 Vesa Karvonen + * + * This code is released under the MLton license, a BSD-style license. + * See the LICENSE file or http://mlton.org/License for details. + *) + +signature Generic = sig + include Generic UNIPLATE +end + +functor MkGeneric (Arg : Generic) = struct + structure Open = MkGeneric (Arg) + open Arg Open + structure UniplateRep = Open.Rep +end + +structure Generic = + MkGeneric (structure Open = WithUniplate (Generic) + open Generic Open) Property changes on: mltonlib/trunk/com/ssh/generic/unstable/with/uniplate.sml ___________________________________________________________________ Name: svn:eol-style + native |
From: Vesa K. <ve...@ml...> - 2008-02-26 09:01:40
|
Comment out unused WORD64. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/framework/ty.sml U mltonlib/trunk/com/ssh/generic/unstable/public/framework/ty.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/framework/ty.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/framework/ty.sml 2008-02-26 11:42:16 UTC (rev 6417) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/framework/ty.sml 2008-02-26 17:01:39 UTC (rev 6418) @@ -25,7 +25,7 @@ structure Con0 = struct datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT | LARGE_REAL | LARGE_WORD | REAL | STRING | UNIT | WORD - | WORD32 | WORD64 | WORD8 + | WORD32 (*| WORD64*) | WORD8 end structure Con1 = struct Modified: mltonlib/trunk/com/ssh/generic/unstable/public/framework/ty.sig =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/framework/ty.sig 2008-02-26 11:42:16 UTC (rev 6417) +++ mltonlib/trunk/com/ssh/generic/unstable/public/framework/ty.sig 2008-02-26 17:01:39 UTC (rev 6418) @@ -26,7 +26,7 @@ structure Con0 : sig datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT | LARGE_REAL | LARGE_WORD | REAL | STRING | UNIT | WORD - | WORD32 | WORD64 | WORD8 + | WORD32 (*| WORD64*) | WORD8 end structure Con1 : sig |
From: Vesa K. <ve...@ml...> - 2008-02-26 03:42:17
|
Formatting. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-02-26 11:26:27 UTC (rev 6416) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-02-26 11:42:16 UTC (rev 6417) @@ -361,8 +361,8 @@ (P {rd = aR, wr = aW, ...}) = P {rd = let open I - fun lp (0, es) = return (fromList (rev es)) - | lp (n, es) = aR >>= (fn e => lp (n-1, e::es)) + fun lp (0, es) = return (fromList (rev es)) + | lp (n, es) = aR >>= (fn e => lp (n-1, e::es)) in rd size >>= lp /> [] end, @@ -408,13 +408,12 @@ (if 0w8 <= h2n (String.sub (s, 0)) then t else f) ^ s end end - fun h2i h = let - val i = valOf (StringCvt.scanString (IntInf.scan StringCvt.HEX) h) - in - if 0w8 <= h2n (String.sub (h, 0)) - then i - IntInf.<< (1, Word.fromInt (IntInf.log2 i + 1)) - else i - end + fun h2i h = + case valOf (StringCvt.scanString (IntInf.scan StringCvt.HEX) h) + of i => + if 0w8 <= h2n (String.sub (h, 0)) + then i - IntInf.<< (1, Word.fromInt (IntInf.log2 i + 1)) + else i val intInf = P {wr = let @@ -564,13 +563,12 @@ fun isoProduct bP = iso' (getP bP) - fun isoSum bS (a2b, b2a) = let - val S {rd, wr, sz} = getS bS - in - S {rd = fn i0 => fn i => I.map b2a (rd i0 i), - wr = fn i0 => wr i0 o a2b, - sz = sz} - end + fun isoSum bS (a2b, b2a) = + case getS bS + of S {rd, wr, sz} => + S {rd = fn i0 => fn i => I.map b2a (rd i0 i), + wr = fn i0 => wr i0 o a2b, + sz = sz} fun lT *` rT = let val P {rd = lR, wr = lW, sz = lS} = getP lT @@ -607,13 +605,12 @@ fun C0 _ = S {rd = const (const (I.return ())), wr = fn i0 => const (i0, id), sz = SOME 0} - fun C1 _ aT = let - val P {rd, wr, sz} = getT aT - in - S {rd = const (const rd), - wr = fn i0 => fn v => (i0, fn t => O.>> (t, wr v)), - sz = sz} - end + fun C1 _ aT = + case getT aT + of P {rd, wr, sz} => + S {rd = const (const rd), + wr = fn i0 => fn v => (i0, fn t => O.>> (t, wr v)), + sz = sz} fun data aS = let val n = Arg.numAlts aS val tag = |
From: Vesa K. <ve...@ml...> - 2008-02-26 03:26:28
|
Fail on degenerate types. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2008-02-26 11:09:20 UTC (rev 6415) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/some.sml 2008-02-26 11:26:27 UTC (rev 6416) @@ -50,7 +50,7 @@ fun C1 _ = getT val data = getS - val Y = Tie.function + fun Y ? = Tie.id (failing "degenerate type") ? fun op --> _ = fn () => failing "Some.-->" (* An alternative implementation would be |
From: Vesa K. <ve...@ml...> - 2008-02-26 03:09:21
|
Added isDegenerate. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2008-02-23 12:32:18 UTC (rev 6414) +++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2008-02-26 11:09:20 UTC (rev 6415) @@ -26,9 +26,12 @@ open TypeInfoRep.This + fun outT (INT r) = r fun outS (INS r) = r fun outP (INP r) = r + fun isDegenerate ? = (not o #base o outT o getT) ? + fun hasBaseCase ? = (#base o outS o getS) ? fun numAlts ? = (#alts o outS o getS) ? Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig =================================================================== --- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2008-02-23 12:32:18 UTC (rev 6414) +++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2008-02-26 11:09:20 UTC (rev 6415) @@ -20,6 +20,14 @@ signature TYPE_INFO = sig structure TypeInfoRep : OPEN_REP + (** == Complete Types == *) + + val isDegenerate : ('a, 'x) TypeInfoRep.t UnPr.t + (** + * Returns true iff the type {'a} is recursive and has no non-recursive + * variants. This means that values of the type cannot be created. + *) + (** == Sums == *) val hasBaseCase : ('a, 'x) TypeInfoRep.s UnPr.t |
From: <jl...@ml...> - 2008-02-23 04:32:19
|
We are not using ps.gz anymore. Reflect this change in the man-pages of mllex and mlyacc. ---------------------------------------------------------------------- U mlton/trunk/man/mllex.1 U mlton/trunk/man/mlyacc.1 ---------------------------------------------------------------------- Modified: mlton/trunk/man/mllex.1 =================================================================== --- mlton/trunk/man/mllex.1 2008-02-19 03:58:08 UTC (rev 6413) +++ mlton/trunk/man/mllex.1 2008-02-23 12:32:18 UTC (rev 6414) @@ -9,7 +9,7 @@ output in \fBfoo.lex.sml\fP a lexer written in SML. For details on the lexer specification, see \fBA Lexical Analyzer Generator for -Standard ML\fP, which is in \fB/usr/share/doc/mllex.ps.gz\fP. +Standard ML\fP, which is in \fB/usr/share/doc/mllex.pdf\fP. .SH "SEE ALSO" Modified: mlton/trunk/man/mlyacc.1 =================================================================== --- mlton/trunk/man/mlyacc.1 2008-02-19 03:58:08 UTC (rev 6413) +++ mlton/trunk/man/mlyacc.1 2008-02-23 12:32:18 UTC (rev 6414) @@ -9,7 +9,7 @@ output in \fBfoo.grm.sig\fP and \fBfoo.grm.sml\fP a parser written in SML. For details on the parser specification, see the \fBML-Yacc User's Manual\fP, -which is in \fB/usr/share/doc/mlyacc.ps.gz\fP. +which is in \fB/usr/share/doc/mlyacc.pdf\fP. .SH "SEE ALSO" |
From: Vesa K. <ve...@ml...> - 2008-02-15 03:22:16
|
Decided to swap the direction of contract composition with andAlso. This means that at covariant positions contract composition with andAlso works like the built-in andalso in the sense that the left hand side contract is asserted first. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml U mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml 2008-02-15 00:52:21 UTC (rev 6411) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml 2008-02-15 11:22:14 UTC (rev 6412) @@ -22,5 +22,5 @@ fn e as Caller _ => raise e | e as Callee _ => raise e | e => raise Caller e) - val op andAlso = op o + fun op andAlso (a, b) = b o a end Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig 2008-02-15 00:52:21 UTC (rev 6411) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig 2008-02-15 11:22:14 UTC (rev 6412) @@ -139,6 +139,6 @@ * * The output from the example is: * - *> D1C1D2C2R2R1 + *> D2C2D1C1R1R2 *) end |
From: Vesa K. <ve...@ml...> - 2008-02-14 16:52:23
|
Added documentation and renamed T -> any and F -> none. ---------------------------------------------------------------------- U mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml U mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig ---------------------------------------------------------------------- Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml 2008-02-14 21:39:40 UTC (rev 6410) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/detail/debug/contract.sml 2008-02-15 00:52:21 UTC (rev 6411) @@ -7,11 +7,10 @@ structure Contract :> CONTRACT = struct type 'a t = 'a UnOp.t exception Contract - exception Caller of Exn.t - exception Callee of Exn.t + exception Caller of Exn.t and Callee of Exn.t val assert = Fn.id - val T = Fn.id - fun F _ = raise Contract + val any = Fn.id + fun none _ = raise Contract val ef = Effect.obs fun pr pr x = if pr x then x else raise Contract fun op --> (d, c) f x = Modified: mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig =================================================================== --- mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig 2008-02-14 21:39:40 UTC (rev 6410) +++ mltonlib/trunk/com/ssh/extended-basis/unstable/public/debug/contract.sig 2008-02-15 00:52:21 UTC (rev 6411) @@ -6,15 +6,60 @@ (** * The {Contract} module provides a combinator library for specifying - * contrants. Inspiration comes mainly from the article: + * contracts as in Design by Contract. * + * As an example, suppose we have a (naively implemented) sqrt function + * + *> fun sqrt x = + *> recur 0 (fn lp => + *> fn y => + *> if x < sq (y+1) then y else lp (y+1)) + * + * where + * + *> fun sq x = x * x + * + * A contract for the function could be specified as + * + *> val sqrtContract = + *> pr (fn x => 0 <= x) --> (fn x => + *> pr (fn y => 0 <= y andalso sq y = x)) + * + * where the first {pr (fn ...)} expression specifies the contract for the + * domain and the second {pr (fn ...)} expression specifies the contract + * for the range of a function. Note that the contract for the range + * depends on the value of the domain for the function invocation. + * + * Now, a "contracted" version of the function could be implemented as + * + *> val csqrt = assert sqrtContract sqrt + * + * Calling the {csqrt} function as {csqrt 4} returns {2}. OTOH, calling + * {csqrt ~4} raises the exception {Caller Contract}, which suggests that + * the caller broke the contract. Also, calling {csqrt 5} raises {Callee + * Contract}, which suggests that the callee broke the contract. In this + * case, however, it is actually the contract that we got wrong. A + * correct contract for sqrt could be specified as: + * + *> val sqrtContract = + *> pr (fn x => 0 <= x) --> (fn x => + *> pr (fn y => 0 <= y andalso sq y <= x andalso x < sq (y+1))) + * + * With the corrected contract, {csqrt 5} returns {2} as expected. + * + * Contracts can be treated as first-class values and thanks to the arrow + * contract constructor, {-->}, contracts generalize to higher-order + * functions. + * + * Inspiration for the {Contract} module comes mainly from the article: + * * Contracts for Higher-Order Functions * Robert Bruce Findler and Matthias Felleisen * ICFP 2002 * [http://citeseer.ist.psu.edu/findler02contracts.html] * * Another combinator library with the same source of inspiration, but a - * different implementation, is described in the article: + * GADT based implementation, is described in the article: * * Typed Contracts for Functional Programming * Ralf Hinze, Johan Jeuring, and Andres Löh @@ -23,14 +68,77 @@ *) signature CONTRACT = sig type 'a t + (** The type constructor of contracts. *) + exception Contract - exception Caller of Exn.t - exception Callee of Exn.t + (** Raised by {pr} when the given predicate is not satisfied. *) + + exception Caller of Exn.t and Callee of Exn.t + (** + * The arrow combinator {-->} tags any raised exception with either + * {Caller} or {Callee} to indicate where the blame for the contract + * violation should be assigned. + *) + val assert : 'a t -> 'a UnOp.t - val T : 'a t - val F : 'a t + (** + * Applies the contract to the given value, returning a (possibly) new + * value. Higher-order values are wrapped with a contract checker that + * checks the contract dynamically. + *) + val ef : 'a Effect.t -> 'a t + (** + * Lifts an effect to a contract. The intention is that the effect + * examines, but does not modify, any given value and raises an + * exception if the value does not satisfy the desired contract. + *) + val pr : 'a UnPr.t -> 'a t + (** + * Lifts a predicate to a contract. The contract raises {Contract} in + * case a value does not satisfy the predicate. + *) + + val any : 'a t + (** + * Contract that is satisfied by any value. {any} is equivalent to {pr + * (const true)}. + *) + + val none : 'a t + (** + * Contract that is not satisfied by any value. {none} is equivalent + * to {pr (const false)}. + *) + + val --> : 'a t * ('a -> 'b t) -> ('a -> 'b) t + (** + * Given a contract for the domain of type {'a} and a contract + * constructor for the range of type {'b}, returns a contract for a + * function of type {'a -> 'b}. + * + * The contract constructor for the range is given the value of the + * domain being passed to the function. Furthermore, it is guaranteed + * that the contract for the range is constructed before the contracted + * function is called. + *) + val andAlso : 'a t BinOp.t - val --> : 'a t * ('a -> 'b t) -> ('a -> 'b) t + (** + * Conjunction of contracts. {a andAlso b} is a contract that is + * satisfied iff both {a} and {b} are satisfied. + * + * To understand the interaction of {-->} and {andAlso}, consider the + * following example: + * + *> fun say ms = ef (fn () => prints ms) + *> fun con i = say ["D", i] --> (fn () => (prints ["C", i] ; say ["R", i])) + * + *> val () = assert (con "1" andAlso con "2") (fn () => ()) () + * + * The output from the example is: + * + *> D1C1D2C2R2R1 + *) end |
From: Matthew F. <fl...@ml...> - 2008-02-14 13:39:42
|
Use symbolic names for object type tags. ---------------------------------------------------------------------- U mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun =================================================================== --- mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 21:39:38 UTC (rev 6409) +++ mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 21:39:40 UTC (rev 6410) @@ -332,13 +332,13 @@ val (tag, hasIdentity, bytesNonObjptrs, numObjptrs) = case ObjectType.toRuntime ty of Array {hasIdentity, bytesNonObjptrs, numObjptrs} => - (0, hasIdentity, + ("ARRAY_TAG", hasIdentity, Bytes.toInt bytesNonObjptrs, numObjptrs) | Normal {hasIdentity, bytesNonObjptrs, numObjptrs} => - (1, hasIdentity, + ("NORMAL_TAG", hasIdentity, Bytes.toInt bytesNonObjptrs, numObjptrs) | Stack => - (2, false, 0, 0) + ("STACK_TAG", false, 0, 0) | Weak {gone} => let val bytesObjptr = @@ -372,10 +372,10 @@ then (bytesNonObjptrs + bytesObjptr, 0) else (bytesNonObjptrs, 1) in - (3, false, bytesNonObjptrs, numObjptrs) + ("WEAK_TAG", false, bytesNonObjptrs, numObjptrs) end in - concat ["{ ", C.int tag, ", ", + concat ["{ ", tag, ", ", C.bool hasIdentity, ", ", C.int bytesNonObjptrs, ", ", C.int numObjptrs, " }"] |
From: Matthew F. <fl...@ml...> - 2008-02-14 13:39:39
|
Explicitly compute padding for thread objects from alignment and target sizes. ---------------------------------------------------------------------- U mlton/trunk/mlton/backend/rep-type.fun ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/backend/rep-type.fun =================================================================== --- mlton/trunk/mlton/backend/rep-type.fun 2008-02-14 21:39:35 UTC (rev 6408) +++ mlton/trunk/mlton/backend/rep-type.fun 2008-02-14 21:39:38 UTC (rev 6409) @@ -407,14 +407,31 @@ val thread = fn () => let val padding = - case (!Control.align, - Bits.toInt (Control.Target.Size.csize ()), - Bits.toInt (Control.Target.Size.objptr ())) of - (Control.Align4,32,32) => Type.word0 - | (Control.Align8,32,32) => Type.word0 - | (Control.Align4,64,64) => Type.word0 - | (Control.Align8,64,64) => Type.word0 - | _ => Error.bug "RepType.ObjectType.thread" + let + val align = + case !Control.align of + Control.Align4 => Bytes.fromInt 4 + | Control.Align8 => Bytes.fromInt 8 + val bytesHeader = + Bits.toBytes (Control.Target.Size.header ()) + val bytesCSize = + Bits.toBytes (Control.Target.Size.csize ()) + val bytesExnStack = + Bits.toBytes (Type.width (Type.exnStack ())) + val bytesStack = + Bits.toBytes (Type.width (Type.stack ())) + + val bytesObject = + Bytes.+ (bytesHeader, + Bytes.+ (bytesCSize, + Bytes.+ (bytesExnStack, + bytesStack))) + val bytesTotal = + Bytes.align (bytesObject, {alignment = align}) + val bytesPad = Bytes.- (bytesTotal, bytesObject) + in + Type.bits (Bytes.toBits bytesPad) + end in Normal {hasIdentity = true, ty = Type.seq (Vector.new4 (padding, |
From: Matthew F. <fl...@ml...> - 2008-02-14 13:39:37
|
Explicitly compute padding for weak objects from alignment and target sizes. ---------------------------------------------------------------------- U mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun =================================================================== --- mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 21:39:32 UTC (rev 6407) +++ mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 21:39:35 UTC (rev 6408) @@ -339,24 +339,41 @@ Bytes.toInt bytesNonObjptrs, numObjptrs) | Stack => (2, false, 0, 0) - | Weak {gone = false} => - (case (!Control.align, - Bits.toInt (Control.Target.Size.cpointer ()), - Bits.toInt (Control.Target.Size.objptr ())) of - (Control.Align4,32,32) => (3, false, 4, 1) - | (Control.Align8,32,32) => (3, false, 8, 1) - | (Control.Align4,64,64) => (3, false, 8, 1) - | (Control.Align8,64,64) => (3, false, 8, 1) - | _ => Error.bug "CCodegen.declareObjectTypes") - | Weak {gone = true} => - (case (!Control.align, - Bits.toInt (Control.Target.Size.cpointer ()), - Bits.toInt (Control.Target.Size.objptr ())) of - (Control.Align4,32,32) => (3, false, 8, 0) - | (Control.Align8,32,32) => (3, false, 12, 0) - | (Control.Align4,64,64) => (3, false, 16, 0) - | (Control.Align8,64,64) => (3, false, 16, 0) - | _ => Error.bug "CCodegen.declareObjectTypes") + | Weak {gone} => + let + val bytesObjptr = + Bits.toBytes (Control.Target.Size.objptr ()) + val bytesNonObjptrs = + let + val align = + case !Control.align of + Control.Align4 => Bytes.fromInt 4 + | Control.Align8 => Bytes.fromInt 8 + val bytesCPointer = + Bits.toBytes (Control.Target.Size.cpointer ()) + val bytesHeader = + Bits.toBytes (Control.Target.Size.header ()) + + val bytesObject = + Bytes.+ (bytesHeader, + Bytes.+ (bytesCPointer, + bytesObjptr)) + val bytesTotal = + Bytes.align (bytesObject, {alignment = align}) + val bytesPad = Bytes.- (bytesTotal, bytesObject) + in + Bytes.+ (bytesPad, bytesCPointer) + end + val (bytesNonObjptrs, bytesObjptr) = + (Bytes.toInt bytesNonObjptrs, + Bytes.toInt bytesObjptr) + val (bytesNonObjptrs, numObjptrs) = + if gone + then (bytesNonObjptrs + bytesObjptr, 0) + else (bytesNonObjptrs, 1) + in + (3, false, bytesNonObjptrs, numObjptrs) + end in concat ["{ ", C.int tag, ", ", C.bool hasIdentity, ", ", |
From: Matthew F. <fl...@ml...> - 2008-02-14 13:39:34
|
Combine the Weak and WeakGone variants in OBJECT_TYPE.t and RUNTIME.RObjectType.t to make it clear that the four variants correspond to the four GC_objectTypeTag kinds. ---------------------------------------------------------------------- U mlton/trunk/mlton/backend/object-type.sig U mlton/trunk/mlton/backend/packed-representation.fun U mlton/trunk/mlton/backend/rep-type.fun U mlton/trunk/mlton/backend/runtime.fun U mlton/trunk/mlton/backend/runtime.sig U mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/backend/object-type.sig =================================================================== --- mlton/trunk/mlton/backend/object-type.sig 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/backend/object-type.sig 2008-02-14 21:39:32 UTC (rev 6407) @@ -17,8 +17,7 @@ | Normal of {hasIdentity: bool, ty: ty} | Stack - | Weak of ty (* in Weak t, must have Type.isPointer t *) - | WeakGone + | Weak of ty option (* in Weak (SOME t), must have Type.isPointer t *) val basic: unit -> (ObjptrTycon.t * t) vector val isOk: t -> bool Modified: mlton/trunk/mlton/backend/packed-representation.fun =================================================================== --- mlton/trunk/mlton/backend/packed-representation.fun 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/backend/packed-representation.fun 2008-02-14 21:39:32 UTC (rev 6407) @@ -2692,7 +2692,7 @@ val r = Value.get r in if Rep.isObjptr r - then SOME (opt, ObjectType.Weak (Rep.ty r)) + then SOME (opt, ObjectType.Weak (SOME (Rep.ty r))) else NONE end) in Modified: mlton/trunk/mlton/backend/rep-type.fun =================================================================== --- mlton/trunk/mlton/backend/rep-type.fun 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/backend/rep-type.fun 2008-02-14 21:39:32 UTC (rev 6407) @@ -361,8 +361,7 @@ | Normal of {hasIdentity: bool, ty: ty} | Stack - | Weak of Type.t - | WeakGone + | Weak of Type.t option fun layout (t: t) = let @@ -378,8 +377,7 @@ record [("hasIdentity", Bool.layout hasIdentity), ("ty", Type.layout ty)]] | Stack => str "Stack" - | Weak t => seq [str "Weak ", Type.layout t] - | WeakGone => str "WeakGone" + | Weak t => seq [str "Weak ", Option.layout Type.layout t] end fun isOk (t: t): bool = @@ -402,8 +400,7 @@ | Control.Align8 => Bits.isWord64Aligned b) end | Stack => true - | Weak t => Type.isObjptr t - | WeakGone => true + | Weak to => Option.fold (to, true, fn (t,_) => Type.isObjptr t) val stack = Stack @@ -427,7 +424,7 @@ end (* Order in the following vector matters. The basic pointer tycons must - * correspond to the constants in gc.h. + * correspond to the constants in gc/object.h. * STACK_TYPE_INDEX, * THREAD_TYPE_INDEX, * WEAK_GONE_TYPE_INDEX, @@ -450,7 +447,7 @@ Vector.fromList [(ObjptrTycon.stack, stack), (ObjptrTycon.thread, thread ()), - (ObjptrTycon.weakGone, WeakGone), + (ObjptrTycon.weakGone, Weak NONE), wordVec 8, wordVec 32, wordVec 16, @@ -479,8 +476,7 @@ numObjptrs = nops} end | Stack => R.Stack - | Weak _ => R.Weak - | WeakGone => R.WeakGone + | Weak to => R.Weak {gone = Option.isNone to} end end Modified: mlton/trunk/mlton/backend/runtime.fun =================================================================== --- mlton/trunk/mlton/backend/runtime.fun 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/backend/runtime.fun 2008-02-14 21:39:32 UTC (rev 6407) @@ -147,8 +147,7 @@ bytesNonObjptrs: Bytes.t, numObjptrs: int} | Stack - | Weak - | WeakGone + | Weak of {gone: bool} fun layout (t: t): Layout.t = let @@ -166,8 +165,9 @@ ("bytesNonObjptrs", Bytes.layout bytesNonObjptrs), ("numObjptrs", Int.layout numObjptrs)]] | Stack => str "Stack" - | Weak => str "Weak" - | WeakGone => str "WeakGone" + | Weak {gone} => + seq [str "Weak", + record [("gone", Bool.layout gone)]] end val _ = layout (* quell unused warning *) end Modified: mlton/trunk/mlton/backend/runtime.sig =================================================================== --- mlton/trunk/mlton/backend/runtime.sig 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/backend/runtime.sig 2008-02-14 21:39:32 UTC (rev 6407) @@ -75,8 +75,7 @@ bytesNonObjptrs: Bytes.t, numObjptrs: int} | Stack - | Weak - | WeakGone + | Weak of {gone: bool} end val allocTooLarge: Bytes.t Modified: mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun =================================================================== --- mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 20:10:55 UTC (rev 6406) +++ mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun 2008-02-14 21:39:32 UTC (rev 6407) @@ -339,7 +339,7 @@ Bytes.toInt bytesNonObjptrs, numObjptrs) | Stack => (2, false, 0, 0) - | Weak => + | Weak {gone = false} => (case (!Control.align, Bits.toInt (Control.Target.Size.cpointer ()), Bits.toInt (Control.Target.Size.objptr ())) of @@ -348,7 +348,7 @@ | (Control.Align4,64,64) => (3, false, 8, 1) | (Control.Align8,64,64) => (3, false, 8, 1) | _ => Error.bug "CCodegen.declareObjectTypes") - | WeakGone => + | Weak {gone = true} => (case (!Control.align, Bits.toInt (Control.Target.Size.cpointer ()), Bits.toInt (Control.Target.Size.objptr ())) of |
From: Matthew F. <fl...@ml...> - 2008-02-14 12:10:56
|
Integrate Wesley Teprstra's mingw updates patch: My previous email explained why the memory management routines for MinGW were broken; see it for an explanation of how this caused the out-of-memory bugs and random crashes when a fixed heap location is used. Some MinGW builds have a symbol gettimeofday, this patch moves our implementation out of the way and continues to use it rather than the symbol exported in an extended mingw library. Ours works for our needs. I re-implemented getrusage. As this now works, gc-summary also works and was enabled. A couple points in this file assumed sizeof(long) >= sizeof(void*). These were corrected. I added more platforms to the uname code now that MinGW supports them. Several headers in MinGW have been changed since the code was last touched. I adjusted timespec and the signals to deal with the least common denominator. I also modified the display maps method to work with 64 bit pointers. Only minor changes from the original patch. ---------------------------------------------------------------------- U mlton/trunk/runtime/gc/init.c U mlton/trunk/runtime/platform/mingw.c U mlton/trunk/runtime/platform/mingw.h U mlton/trunk/runtime/platform/windows.c ---------------------------------------------------------------------- Modified: mlton/trunk/runtime/gc/init.c =================================================================== --- mlton/trunk/runtime/gc/init.c 2008-02-14 19:49:03 UTC (rev 6405) +++ mlton/trunk/runtime/gc/init.c 2008-02-14 20:10:55 UTC (rev 6406) @@ -114,11 +114,7 @@ s->controls.messages = TRUE; } else if (0 == strcmp (arg, "gc-summary")) { i++; -#if (defined (__MINGW32__)) - fprintf (stderr, "Warning: MinGW doesn't support gc-summary.\n"); -#else s->controls.summary = TRUE; -#endif } else if (0 == strcmp (arg, "grow-ratio")) { i++; if (i == argc) Modified: mlton/trunk/runtime/platform/mingw.c =================================================================== --- mlton/trunk/runtime/platform/mingw.c 2008-02-14 19:49:03 UTC (rev 6405) +++ mlton/trunk/runtime/platform/mingw.c 2008-02-14 20:10:55 UTC (rev 6406) @@ -8,6 +8,10 @@ Windows_decommit (base, length); } +void *GC_mremap (void *base, size_t old, size_t new) { + return Windows_mremap (base, old, new); +} + void *GC_mmapAnon (void *start, size_t length) { return Windows_mmapAnon (start, length); } @@ -18,11 +22,17 @@ } uintmax_t GC_physMem (void) { +#ifdef _WIN64 + MEMORYSTATUSEX memstat; + memstat.dwLength = sizeof(memstat); + GlobalMemoryStatusEx(&memstat); + return (uintmax_t)memstat.ullTotalPhys; +#else MEMORYSTATUS memstat; - memstat.dwLength = sizeof(memstat); GlobalMemoryStatus(&memstat); return (uintmax_t)memstat.dwTotalPhys; +#endif } size_t GC_pageSize (void) { @@ -33,7 +43,7 @@ HANDLE fileDesHandle (int fd) { // The temporary prevents a "cast does not match function type" warning. - long t; + intptr_t t; t = _get_osfhandle (fd); return (HANDLE)t; @@ -66,7 +76,8 @@ /* Based on notes by Wu Yongwei: * http://mywebpage.netscape.com/yongweiwutime.htm */ -int gettimeofday (struct timeval *tv, struct timezone *tz) { +int mlton_gettimeofday (struct timeval *tv, + __attribute__ ((unused)) struct timezone *tz) { FILETIME ft; LARGE_INTEGER li; __int64 t; @@ -150,29 +161,50 @@ /* GetProcessTimes and GetSystemTimeAsFileTime are documented at: * http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/getprocesstimes.asp - * http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/base/getsystemtimeasfiletime.asp */ -int getrusage (__attribute__ ((unused)) int who, struct rusage *usage) { - FILETIME ct, et, kt, ut; - LARGE_INTEGER li, lj; - if (GetProcessTimes(GetCurrentProcess(), &ct, &et, &kt, &ut)) { - usage->ru_utime.tv_sec = ut.dwHighDateTime; - usage->ru_utime.tv_usec = ut.dwLowDateTime/10; - usage->ru_stime.tv_sec = kt.dwHighDateTime; - usage->ru_stime.tv_usec = kt.dwLowDateTime/10; +int getrusage (int who, struct rusage *usage) { + /* FILETIME has dw{High,Low}DateTime which store the number of + * 100-nanoseconds since January 1, 1601 + */ + FILETIME creation_time; + FILETIME exit_time; + FILETIME kernel_time; + FILETIME user_time; + + uint64_t user_usecs, kernel_usecs; + + if (who == RUSAGE_CHILDREN) { + // !!! could use exit_time - creation_time from cwait + memset(usage, 0, sizeof(struct rusage)); return 0; } - /* if GetProcessTimes failed, use real time [for Windows] */ - GetSystemTimeAsFileTime(&ut); - li.LowPart = ut.dwLowDateTime; - li.HighPart = ut.dwHighDateTime; - lj.LowPart = Time_sec; - lj.HighPart = Time_usec; - li.QuadPart -= lj.QuadPart; - usage->ru_utime.tv_sec = li.HighPart; - usage->ru_utime.tv_usec = li.LowPart/10; - usage->ru_stime.tv_sec = 0; - usage->ru_stime.tv_usec = 0; + + if (who != RUSAGE_SELF) { + errno = EINVAL; + return -1; + } + + if (GetProcessTimes(GetCurrentProcess(), + &creation_time, &exit_time, + &kernel_time, &user_time) == 0) { + errno = EFAULT; + return -1; + } + + kernel_usecs = kernel_time.dwHighDateTime; + kernel_usecs <<= sizeof(kernel_time.dwHighDateTime)*8; + kernel_usecs |= kernel_time.dwLowDateTime; + kernel_usecs /= 10; + + user_usecs = user_time.dwHighDateTime; + user_usecs <<= sizeof(user_time.dwHighDateTime)*8; + user_usecs |= user_time.dwLowDateTime; + user_usecs /= 10; + + usage->ru_utime.tv_sec = user_usecs / 1000000; + usage->ru_utime.tv_usec = user_usecs % 1000000; + usage->ru_stime.tv_sec = kernel_usecs / 1000000; + usage->ru_stime.tv_usec = kernel_usecs % 1000000; return 0; } @@ -195,7 +227,7 @@ HANDLE fh, fhmap; DWORD fileSize, fileSizeHi; void* pMem = NULL; - long tmp; + intptr_t tmp; tmp = _get_osfhandle (fd); fh = (HANDLE)tmp; @@ -331,8 +363,8 @@ /* This requires Win98+ * Choosing text/binary mode is defered till a later setbin/text call */ - filedes[0] = _open_osfhandle((long)read_h, _O_RDONLY); - filedes[1] = _open_osfhandle((long)write_h, _O_WRONLY); + filedes[0] = _open_osfhandle((intptr_t)read_h, _O_RDONLY); + filedes[1] = _open_osfhandle((intptr_t)write_h, _O_WRONLY); if (filedes[0] == -1 or filedes[1] == -1) { if (filedes[0] == -1) CloseHandle(read_h); @@ -474,14 +506,15 @@ if (level > 6) level = 6; platform = "i%d86"; break; - case PROCESSOR_ARCHITECTURE_IA64: platform = "ia64"; break; -#ifndef PROCESSOR_ARCHITECTURE_AMD64 -#define PROCESSOR_ARCHITECTURE_AMD64 9 -#endif - case PROCESSOR_ARCHITECTURE_AMD64: platform = "amd64"; break; - - case PROCESSOR_ARCHITECTURE_ALPHA: platform = "alpha"; break; - case PROCESSOR_ARCHITECTURE_MIPS: platform = "mips"; break; + case PROCESSOR_ARCHITECTURE_IA64: platform = "ia64"; break; + case PROCESSOR_ARCHITECTURE_AMD64: platform = "amd64"; break; + case PROCESSOR_ARCHITECTURE_PPC: platform = "ppc"; break; + case PROCESSOR_ARCHITECTURE_ALPHA: platform = "alpha"; break; + case PROCESSOR_ARCHITECTURE_MIPS: platform = "mips"; break; + case PROCESSOR_ARCHITECTURE_ARM: platform = "arm"; break; + case PROCESSOR_ARCHITECTURE_ALPHA64: platform = "alpha64"; break; + /* SHX? MSIL? IA32_ON_WIN64? */ + default: platform = "unknown"; break; } sprintf (buf->machine, platform, level); } @@ -510,6 +543,9 @@ case VER_PLATFORM_WIN32s: os = "31"; /* aka DOS + Windows 3.1 */ break; + default: + os = "unknown"; + break; } sprintf (buf->sysname, "MINGW32_%s-%d.%d", os, (int)osv.dwMajorVersion, (int)osv.dwMinorVersion); @@ -520,9 +556,9 @@ unless (0 == gethostname (buf->nodename, sizeof (buf->nodename))) { strcpy (buf->nodename, "unknown"); } - sprintf (buf->release, "%d", __MINGW32_MINOR_VERSION); + sprintf (buf->release, "%d", 0); //__MINGW32_MINOR_VERSION); setSysname (buf); - sprintf (buf->version, "%d", __MINGW32_MAJOR_VERSION); + sprintf (buf->version, "%d", 0); //__MINGW32_MAJOR_VERSION); return 0; } @@ -580,7 +616,7 @@ } __attribute__ ((noreturn)) -pid_t fork (void) { +int fork (void) { die ("fork not implemented"); } @@ -882,7 +918,7 @@ die ("socketpair not implemented"); } -void MLton_initSockets () { +void MLton_initSockets (void) { static Bool isInitialized = FALSE; WORD version; WSADATA wsaData; @@ -1000,7 +1036,7 @@ } { - void* result = GetProcAddress(hmodule, symbol); + void* result = (void*)GetProcAddress(hmodule, symbol); if (!result) dlerror_last = GetLastError(); @@ -1030,5 +1066,5 @@ /* ------------------------------------------------- */ C_Size_t MinGW_getTempPath(C_Size_t buf_size, Array(Char8_t) buf) { - return GetTempPath(buf_size, buf); + return GetTempPath(buf_size, (char*)buf); } Modified: mlton/trunk/runtime/platform/mingw.h =================================================================== --- mlton/trunk/runtime/platform/mingw.h 2008-02-14 19:49:03 UTC (rev 6405) +++ mlton/trunk/runtime/platform/mingw.h 2008-02-14 20:10:55 UTC (rev 6406) @@ -32,7 +32,7 @@ #define HAS_FPCLASSIFY32 FALSE #define HAS_FPCLASSIFY64 FALSE #define HAS_MSG_DONTWAIT TRUE -#define HAS_REMAP FALSE +#define HAS_REMAP TRUE #define HAS_SIGALTSTACK FALSE #define HAS_SIGNBIT TRUE #define HAS_SPAWN TRUE @@ -88,13 +88,12 @@ /* Date */ /* ------------------------------------------------- */ -struct timezone { - int tz_dsttime; - int tz_minuteswest; -}; +/* MinGW provides gettimeofday in -lmingwex, which we don't link. + * In order to avoid a name conflict, we use a different name. + */ +int mlton_gettimeofday (struct timeval *tv, struct timezone *tz); +#define gettimeofday mlton_gettimeofday -int gettimeofday (struct timeval *tv, struct timezone *tz); - /* ------------------------------------------------- */ /* MLton.Itimer */ /* ------------------------------------------------- */ @@ -207,6 +206,10 @@ #define S_ISLNK(m) (m?FALSE:FALSE) #define S_ISSOCK(m) (m?FALSE:FALSE) +#ifndef O_ACCMODE +#define O_ACCMODE O_RDONLY|O_WRONLY|O_RDWR +#endif + int chown (const char *path, uid_t owner, gid_t group); int fchmod (int filedes, mode_t mode); int fchdir (int filedes); @@ -314,14 +317,18 @@ #define WTERMSIG(w) ((w) & 0x7f) #define WSTOPSIG WEXITSTATUS +/* Sometimes defined by mingw */ +#ifndef TIMESPEC_DEFINED +struct timespec { + time_t tv_sec; + long tv_nsec; +}; +#endif + int alarm (int secs); -pid_t fork (void); +int fork(void); /* mingw demands this return int */ int kill (pid_t pid, int sig); int pause (void); -struct timespec { - time_t tv_sec; - long tv_nsec; -}; int nanosleep (const struct timespec *req, struct timespec *rem); unsigned int sleep (unsigned int seconds); pid_t wait (int *status); @@ -335,26 +342,64 @@ #define SIG_SETMASK 0 #define SIG_UNBLOCK 2 +/* Sometimes mingw defines some of these. Some not. Some always. */ + +#ifndef SIGHUP #define SIGHUP 1 -#define SIGKILL 2 -#define SIGPIPE 3 -#define SIGQUIT 9 -#define SIGALRM 13 -#define SIGBUS 14 +#endif + +/* SIGINT = 2 */ + +#ifndef SIGQUIT +#define SIGQUIT 3 +#endif + +/* SIGILL = 4 */ +/* SIGTRAP = 5 (unused) */ +/* SIGIOT = 6 (unused) */ +/* SIGABRT = 6 (unused) */ +/* SIGEMT = 7 (unused) */ +/* SIGFPE = 8 */ + +#ifndef SIGKILL +#define SIGKILL 9 +#endif + +#ifndef SIGBUS +#define SIGBUS 10 +#endif + +/* SIGSEGV = 11 */ +/* SIGSYS = 12 (unused) */ + +#ifndef SIGPIPE +#define SIGPIPE 13 +#endif + +#ifndef SIGALRM +#define SIGALRM 14 +#endif + +/* SIGTERM = 15 */ +/* SIGBREAK = 21 */ +/* SIGABRT2 = 22 */ + +/* These signals are fake. They do not exist on windows. */ #define SIGSTOP 16 #define SIGTSTP 18 -#define SIGCHLD 20 -#define SIGTTIN 21 -#define SIGTTOU 22 -#define SIGCONT 25 -#define SIGUSR1 25 -#define SIGUSR2 26 -#define SIGVTALRM 26 /* virtual time alarm */ -#define SIGPROF 27 /* profiling time alarm */ +#define SIGCHLD 23 +#define SIGTTIN 24 +#define SIGTTOU 25 +#define SIGCONT 26 +#define SIGUSR1 27 +#define SIGUSR2 28 +#define SIGVTALRM 29 /* virtual time alarm */ +#define SIGPROF 30 /* profiling time alarm */ #define _NSIG 32 typedef __p_sig_fn_t _sig_func_ptr; +typedef int sigset_t; /* sometimes defined my mingw as int */ struct sigaction { int sa_flags; @@ -529,8 +574,10 @@ /* ------------------------------------------------- */ // Unimplemented on windows: +#ifndef MSG_WAITALL +#define MSG_WAITALL 0x8 +#endif #define MSG_DONTWAIT 0 -#define MSG_WAITALL 0 #define MSG_EOR 0 #define MSG_CTRUNC 0 Modified: mlton/trunk/runtime/platform/windows.c =================================================================== --- mlton/trunk/runtime/platform/windows.c 2008-02-14 19:49:03 UTC (rev 6405) +++ mlton/trunk/runtime/platform/windows.c 2008-02-14 20:10:55 UTC (rev 6406) @@ -1,6 +1,7 @@ HANDLE fileDesHandle (int fd); -#define BUFSIZE 65536 +/* As crazy as it is, this breaks Windows 2003&Vista: #define BUFSIZE 65536 */ +#define BUFSIZE 10240 static HANDLE tempFileDes (void) { /* Based on http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/creating_and_using_a_temporary_file.asp @@ -13,11 +14,12 @@ char lpPathBuffer[BUFSIZE]; dwRetVal = GetTempPath(dwBufSize, lpPathBuffer); - if (dwRetVal > dwBufSize) + if (dwRetVal >= dwBufSize) die ("GetTempPath failed with error %ld\n", GetLastError()); uRetVal = GetTempFileName(lpPathBuffer, "TempFile", 0, szTempName); if (0 == uRetVal) - die ("GetTempFileName failed with error %ld\n", GetLastError()); + die ("GetTempFileName in %s failed with error %ld\n", + lpPathBuffer, GetLastError()); hTempFile = CreateFile((LPTSTR) szTempName, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL | FILE_FLAG_DELETE_ON_CLOSE, NULL); @@ -67,12 +69,18 @@ static void displayMaps (void) { MEMORY_BASIC_INFORMATION buf; - LPVOID lpAddress; const char *state = "<unset>"; const char *protect = "<unset>"; + uintptr_t address; - for (lpAddress = 0; lpAddress < (LPCVOID)0x80000000; ) { - VirtualQuery (lpAddress, &buf, sizeof (buf)); + buf.RegionSize = 0; + for (address = 0; + address + buf.RegionSize >= address; + address += buf.RegionSize) { + if (0 == VirtualQuery ((LPCVOID)address, &buf, sizeof (buf))) + break; + if (0 == buf.RegionSize) + break; switch (buf.Protect) { case PAGE_READONLY: @@ -121,26 +129,49 @@ default: assert (FALSE); } - fprintf(stderr, "0x%8x %10u %s %s\n", - (unsigned int)buf.BaseAddress, - (unsigned int)buf.RegionSize, + + fprintf(stderr, FMTPTR " %10"PRIuMAX" %s %s\n", + buf.BaseAddress, (uintmax_t)buf.RegionSize, state, protect); - lpAddress = (unsigned char*)lpAddress + buf.RegionSize; } } void GC_displayMem (void) { - MEMORYSTATUS ms; +#ifdef _WIN64 + MEMORYSTATUSEX ms; + ms.dwLength = sizeof (MEMORYSTATUSEX); + GlobalMemoryStatusEx (&ms); - ms.dwLength = sizeof (MEMORYSTATUS); - GlobalMemoryStatus (&ms); - fprintf(stderr, "Total Phys. Mem: %ld\nAvail Phys. Mem: %ld\nTotal Page File: %ld\nAvail Page File: %ld\nTotal Virtual: %ld\nAvail Virtual: %ld\n", - ms.dwTotalPhys, - ms.dwAvailPhys, - ms.dwTotalPageFile, - ms.dwAvailPageFile, - ms.dwTotalVirtual, - ms.dwAvailVirtual); + fprintf(stderr, "Total Phys. Mem: %"PRIuMAX"\n" + "Avail Phys. Mem: %"PRIuMAX"\n" + "Total Page File: %"PRIuMAX"\n" + "Avail Page File: %"PRIuMAX"\n" + "Total Virtual: %"PRIuMAX"\n" + "Avail Virtual: %"PRIuMAX"\n", + (uintmax_t)ms.ullTotalPhys, + (uintmax_t)ms.ullAvailPhys, + (uintmax_t)ms.ullTotalPageFile, + (uintmax_t)ms.ullAvailPageFile, + (uintmax_t)ms.ullTotalVirtual, + (uintmax_t)ms.ullAvailVirtual); +#else + MEMORYSTATUS ms; + ms.dwLength = sizeof (MEMORYSTATUS); + GlobalMemoryStatus (&ms); + + fprintf(stderr, "Total Phys. Mem: %"PRIuMAX"\n" + "Avail Phys. Mem: %"PRIuMAX"\n" + "Total Page File: %"PRIuMAX"\n" + "Avail Page File: %"PRIuMAX"\n" + "Total Virtual: %"PRIuMAX"\n" + "Avail Virtual: %"PRIuMAX"\n", + (uintmax_t)ms.dwTotalPhys, + (uintmax_t)ms.dwAvailPhys, + (uintmax_t)ms.dwTotalPageFile, + (uintmax_t)ms.dwAvailPageFile, + (uintmax_t)ms.dwTotalVirtual, + (uintmax_t)ms.dwAvailVirtual); +#endif displayMaps (); } @@ -176,16 +207,64 @@ die ("VirtualFree decommit failed"); } -static inline void *Windows_mmapAnon (__attribute__ ((unused)) void *start, - size_t length) { +static inline void *Windows_mremap (void *base, size_t old, size_t new) { void *res; + void *tail; - /* Use "0" instead of "start" as the first argument to VirtualAlloc - * because it is more stable on MinGW (at least). + /* Attempt to recover decommit'd memory */ + tail = (void*)((intptr_t)base + old); + res = VirtualAlloc(tail, new - old, MEM_COMMIT, PAGE_READWRITE); + if (NULL == res) + return (void*)-1; + + return base; +} + +static inline void *Windows_mmapAnon (void *start, size_t length) { + void *res; + size_t reserve; + + /* If length > 256MB on win32, we round up to the nearest 512MB. + * By reserving more than we need, we can later mremap to use it. + * This avoids fragmentation on 32 bit machines, near the 2GB limit. + * It doesn't hurt us in 64 bit mode either (lots of address space). */ - res = VirtualAlloc ((LPVOID)0/*start*/, length, MEM_COMMIT, PAGE_READWRITE); + if (length > ((size_t)1 << 28)) + reserve = align (length, ((size_t)1 << 29)); + else reserve = length; + + /* We prevoiusly used "0" instead of start, which lead to crashes. + * After reading win32 documentation, the reason for these crashes + * becomes clear: we were using only MEM_COMMIT! If there was memory + * decommitted in a previous heap shrink, a new heap might end up + * inside the reserved (but uncommitted) memory. When the old heap is + * freed, it will kill the new heap as well. This bug will not happen + * now because we reserve, then commit. Reserved memory cannot conflict. + */ + res = VirtualAlloc (start, reserve, MEM_RESERVE, PAGE_NOACCESS); + + /* Try shifting the block left (to play well with MLton's scan) */ + if (NULL == res) { + uintptr_t base = (uintptr_t)start; + size_t shift = reserve - length; + if (base > shift) + res = VirtualAlloc ((void*)(base-shift), reserve, + MEM_RESERVE, PAGE_NOACCESS); + } + + /* Fall back to zero reserved allocation */ if (NULL == res) - res = (void*)-1; + res = VirtualAlloc (start, length, MEM_RESERVE, PAGE_NOACCESS); + + /* Nothing more we can try at this offset */ + if (NULL == res) + return (void*)-1; + + /* Actually get the memory for use */ + res = VirtualAlloc (res, length, MEM_COMMIT, PAGE_READWRITE); + if (NULL == res) + die("VirtualAlloc MEM_COMMIT of MEM_RESERVEd memory failed!\n"); + return res; } @@ -200,7 +279,7 @@ char *cmd; char *arg; char *env; - int result; + C_PId_t result; STARTUPINFO si; PROCESS_INFORMATION proc; @@ -243,7 +322,7 @@ * The thread handle is not needed, so clean it. */ CloseHandle (proc.hThread); - result = (int)proc.hProcess; + result = (C_PId_t)proc.hProcess; } CloseHandle (si.hStdInput); CloseHandle (si.hStdOutput); |
From: Matthew F. <fl...@ml...> - 2008-02-14 11:49:04
|
Add comment and fix tag indices. ---------------------------------------------------------------------- U mlton/trunk/runtime/gc/object.h ---------------------------------------------------------------------- Modified: mlton/trunk/runtime/gc/object.h =================================================================== --- mlton/trunk/runtime/gc/object.h 2008-02-14 18:13:42 UTC (rev 6404) +++ mlton/trunk/runtime/gc/object.h 2008-02-14 19:49:03 UTC (rev 6405) @@ -13,10 +13,12 @@ * array, normal (fixed size), stack, and weak. */ typedef enum { - ARRAY_TAG, - NORMAL_TAG, - STACK_TAG, - WEAK_TAG, + /* The tag indices here must agree with those in declareObjectTypes() + * in codegen/c-codegen/c-codegen.fun. */ + ARRAY_TAG = 0, + NORMAL_TAG = 1, + STACK_TAG = 2, + WEAK_TAG = 3, } GC_objectTypeTag; #endif /* (defined (MLTON_GC_INTERNAL_TYPES)) */ |
From: Matthew F. <fl...@ml...> - 2008-02-14 10:13:45
|
Integrate Wesley Teprstra's pid not int patch: The old windows bindings for spawn assumed that it returns an int. However, it is actually returning a pid. This causes problems for win64, but was wrong for win32 as well. Only minor changes from the original patch. The "pid-not-int" actually refers to two aspects: * the spawn* functions return a pid, not an int. * fix a simple type error when C_PId.t <> C_Int.t ---------------------------------------------------------------------- U mlton/trunk/basis-library/posix/proc-env.sml U mlton/trunk/basis-library/primitive/basis-ffi.sml U mlton/trunk/runtime/basis/MLton/Process/spawne.c U mlton/trunk/runtime/basis/MLton/Process/spawnp.c U mlton/trunk/runtime/basis-ffi.h U mlton/trunk/runtime/gen/basis-ffi.def U mlton/trunk/runtime/gen/basis-ffi.h U mlton/trunk/runtime/gen/basis-ffi.sml ---------------------------------------------------------------------- Modified: mlton/trunk/basis-library/posix/proc-env.sml =================================================================== --- mlton/trunk/basis-library/posix/proc-env.sml 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/basis-library/posix/proc-env.sml 2008-02-14 18:13:42 UTC (rev 6404) @@ -33,7 +33,9 @@ val setuid = fn uid => SysCall.simple (fn () => setuid uid) end - fun setsid () = SysCall.simpleResult (Prim.setsid) + fun setsid () = + SysCall.simpleResult' + ({errVal = C_PId.castFromFixedInt ~1}, Prim.setsid) val uidToWord = C_UId.castToSysWord val wordToUid = C_UId.castFromSysWord Modified: mlton/trunk/basis-library/primitive/basis-ffi.sml =================================================================== --- mlton/trunk/basis-library/primitive/basis-ffi.sml 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/basis-library/primitive/basis-ffi.sml 2008-02-14 18:13:42 UTC (rev 6404) @@ -80,8 +80,8 @@ structure Process = struct val cwait = _import "MLton_Process_cwait" : C_PId.t * (C_Status.t) ref -> (C_PId.t) C_Errno.t; -val spawne = _import "MLton_Process_spawne" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_Int.t) C_Errno.t; -val spawnp = _import "MLton_Process_spawnp" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_Int.t) C_Errno.t; +val spawne = _import "MLton_Process_spawne" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_PId.t) C_Errno.t; +val spawnp = _import "MLton_Process_spawnp" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_PId.t) C_Errno.t; end structure Rlimit = struct Modified: mlton/trunk/runtime/basis/MLton/Process/spawne.c =================================================================== --- mlton/trunk/runtime/basis/MLton/Process/spawne.c 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/basis/MLton/Process/spawne.c 2008-02-14 18:13:42 UTC (rev 6404) @@ -2,7 +2,7 @@ #if HAS_SPAWN -C_Errno_t(C_Int_t) MLton_Process_spawne (NullString8_t pNStr, +C_Errno_t(C_PId_t) MLton_Process_spawne (NullString8_t pNStr, String8_t aStr, Array(C_Pointer_t) aPtr, Vector(C_Size_t) aOff, @@ -14,7 +14,7 @@ char **env; int aLen; int eLen; - int res; + C_PId_t res; path = (const char *) pNStr; args = (char **) aPtr; @@ -32,13 +32,13 @@ res = spawnve (SPAWN_MODE, path, (const char * const *)args, (const char * const *)env); - return res; + return (C_Errno_t(C_PId_t))res; } #else __attribute__ ((noreturn)) -C_Errno_t(C_Int_t) MLton_Process_spawne (__attribute__ ((unused))NullString8_t pNStr, +C_Errno_t(C_PId_t) MLton_Process_spawne (__attribute__ ((unused))NullString8_t pNStr, __attribute__ ((unused))String8_t aStr, __attribute__ ((unused))Array(C_Pointer_t) aPtr, __attribute__ ((unused))Vector(C_Size_t) aOff, Modified: mlton/trunk/runtime/basis/MLton/Process/spawnp.c =================================================================== --- mlton/trunk/runtime/basis/MLton/Process/spawnp.c 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/basis/MLton/Process/spawnp.c 2008-02-14 18:13:42 UTC (rev 6404) @@ -2,14 +2,14 @@ #if HAS_SPAWN -C_Errno_t(C_Int_t) MLton_Process_spawnp (NullString8_t pNStr, +C_Errno_t(C_PId_t) MLton_Process_spawnp (NullString8_t pNStr, String8_t aStr, Array(C_Pointer_t) aPtr, Vector(C_Size_t) aOff) { const char *path; char **args; int aLen; - int res; + C_PId_t res; path = (const char *) pNStr; args = (char **) aPtr; @@ -20,13 +20,13 @@ args[aLen - 1] = NULL; res = spawnvp (SPAWN_MODE, path, (const char * const *)args); - return (C_Errno_t(C_Int_t))res; + return (C_Errno_t(C_PId_t))res; } #else __attribute__ ((noreturn)) -C_Errno_t(C_Int_t) MLton_Process_spawnp (__attribute__ ((unused)) NullString8_t pNStr, +C_Errno_t(C_PId_t) MLton_Process_spawnp (__attribute__ ((unused)) NullString8_t pNStr, __attribute__ ((unused)) String8_t aStr, __attribute__ ((unused)) Array(C_Pointer_t) aPtr, __attribute__ ((unused)) Vector(C_Size_t) aOff) { Modified: mlton/trunk/runtime/basis-ffi.h =================================================================== --- mlton/trunk/runtime/basis-ffi.h 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/basis-ffi.h 2008-02-14 18:13:42 UTC (rev 6404) @@ -51,8 +51,8 @@ C_Errno_t(C_Int_t) MLton_Itimer_set(C_Int_t,C_Time_t,C_SUSeconds_t,C_Time_t,C_SUSeconds_t); extern const C_Int_t MLton_Itimer_VIRTUAL; C_Errno_t(C_PId_t) MLton_Process_cwait(C_PId_t,Ref(C_Status_t)); -C_Errno_t(C_Int_t) MLton_Process_spawne(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t),String8_t,Array(C_Pointer_t),Vector(C_Size_t)); -C_Errno_t(C_Int_t) MLton_Process_spawnp(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t)); +C_Errno_t(C_PId_t) MLton_Process_spawne(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t),String8_t,Array(C_Pointer_t),Vector(C_Size_t)); +C_Errno_t(C_PId_t) MLton_Process_spawnp(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t)); extern const C_Int_t MLton_Rlimit_AS; extern const C_Int_t MLton_Rlimit_CORE; extern const C_Int_t MLton_Rlimit_CPU; Modified: mlton/trunk/runtime/gen/basis-ffi.def =================================================================== --- mlton/trunk/runtime/gen/basis-ffi.def 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/gen/basis-ffi.def 2008-02-14 18:13:42 UTC (rev 6404) @@ -43,8 +43,8 @@ MLton.Itimer.VIRTUAL = _const : C_Int.t MLton.Itimer.set = _import : C_Int.t * C_Time.t * C_SUSeconds.t * C_Time.t * C_SUSeconds.t -> C_Int.t C_Errno.t MLton.Process.cwait = _import : C_PId.t * C_Status.t ref -> C_PId.t C_Errno.t -MLton.Process.spawne = _import : NullString8.t * String8.t * C_Pointer.t array * C_Size.t vector * String8.t * C_Pointer.t array * C_Size.t vector -> C_Int.t C_Errno.t -MLton.Process.spawnp = _import : NullString8.t * String8.t * C_Pointer.t array * C_Size.t vector -> C_Int.t C_Errno.t +MLton.Process.spawne = _import : NullString8.t * String8.t * C_Pointer.t array * C_Size.t vector * String8.t * C_Pointer.t array * C_Size.t vector -> C_PId.t C_Errno.t +MLton.Process.spawnp = _import : NullString8.t * String8.t * C_Pointer.t array * C_Size.t vector -> C_PId.t C_Errno.t MLton.Rlimit.AS = _const : C_Int.t MLton.Rlimit.CORE = _const : C_Int.t MLton.Rlimit.CPU = _const : C_Int.t Modified: mlton/trunk/runtime/gen/basis-ffi.h =================================================================== --- mlton/trunk/runtime/gen/basis-ffi.h 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/gen/basis-ffi.h 2008-02-14 18:13:42 UTC (rev 6404) @@ -51,8 +51,8 @@ C_Errno_t(C_Int_t) MLton_Itimer_set(C_Int_t,C_Time_t,C_SUSeconds_t,C_Time_t,C_SUSeconds_t); extern const C_Int_t MLton_Itimer_VIRTUAL; C_Errno_t(C_PId_t) MLton_Process_cwait(C_PId_t,Ref(C_Status_t)); -C_Errno_t(C_Int_t) MLton_Process_spawne(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t),String8_t,Array(C_Pointer_t),Vector(C_Size_t)); -C_Errno_t(C_Int_t) MLton_Process_spawnp(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t)); +C_Errno_t(C_PId_t) MLton_Process_spawne(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t),String8_t,Array(C_Pointer_t),Vector(C_Size_t)); +C_Errno_t(C_PId_t) MLton_Process_spawnp(NullString8_t,String8_t,Array(C_Pointer_t),Vector(C_Size_t)); extern const C_Int_t MLton_Rlimit_AS; extern const C_Int_t MLton_Rlimit_CORE; extern const C_Int_t MLton_Rlimit_CPU; Modified: mlton/trunk/runtime/gen/basis-ffi.sml =================================================================== --- mlton/trunk/runtime/gen/basis-ffi.sml 2008-02-14 17:04:57 UTC (rev 6403) +++ mlton/trunk/runtime/gen/basis-ffi.sml 2008-02-14 18:13:42 UTC (rev 6404) @@ -80,8 +80,8 @@ structure Process = struct val cwait = _import "MLton_Process_cwait" : C_PId.t * (C_Status.t) ref -> (C_PId.t) C_Errno.t; -val spawne = _import "MLton_Process_spawne" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_Int.t) C_Errno.t; -val spawnp = _import "MLton_Process_spawnp" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_Int.t) C_Errno.t; +val spawne = _import "MLton_Process_spawne" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_PId.t) C_Errno.t; +val spawnp = _import "MLton_Process_spawnp" : NullString8.t * String8.t * (C_Pointer.t) array * (C_Size.t) vector -> (C_PId.t) C_Errno.t; end structure Rlimit = struct |
From: Matthew F. <fl...@ml...> - 2008-02-14 09:04:58
|
Integrate Wesley Teprstra's cross compiler option changed patch: I earlier had people add the '-b' flag as gcc needed it for cross compiling. Newer gcc no longer accepts this option. Instead, the platform prefixs the gcc executable. This patch corrects this. If the old behaviour is needed for old gcc, a simple shell wrapper works. Also, when cross compiling, not only gcc, but also ar and ranlib need the executable prefix. The runtime/Makefile also presumed CC=gcc at one point. Some changes from the original patch: * the "-cc <gcc>" expert option is documented to accept a path to the gcc executable; only prefix the target to the file portion of the path. ---------------------------------------------------------------------- U mlton/trunk/mlton/main/main.fun U mlton/trunk/runtime/Makefile ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/main/main.fun =================================================================== --- mlton/trunk/mlton/main/main.fun 2008-02-14 16:15:52 UTC (rev 6402) +++ mlton/trunk/mlton/main/main.fun 2008-02-14 17:04:57 UTC (rev 6403) @@ -851,7 +851,23 @@ fun tokenize l = String.tokens (concat (List.separate (l, " ")), Char.isSpace) - val gcc = !gcc + (* When cross-compiling, use the named cross compiler. + * Older gcc versions used -b for multiple targets. + * If this is still needed, a shell script wrapper can hide this. + *) + val gcc = + case target of + Cross s => + let + val {dir = gccDir, file = gccFile} = + OS.Path.splitDirFile (!gcc) + in + OS.Path.joinDirFile + {dir = gccDir, + file = s ^ "-" ^ gccFile} + end + | Self => !gcc + fun addTargetOpts opts = List.fold (!opts, [], fn ({opt, pred}, ac) => @@ -872,15 +888,6 @@ List.concat [[concat ["-L", !libTargetDir], if !debugRuntime then "-lmlton-gdb" else "-lmlton"], addTargetOpts linkOpts] - (* With gcc 3.4, the '-b <arch>' must be the first argument. *) - val targetOpts = - case target of - Cross s => - if Cygwin = MLton.Platform.OS.host - andalso String.hasSubstring (s, {substring = "mingw"}) - then ["-mno-cygwin"] - else ["-b", s] - | Self => [] val _ = if not (hasCodegen (!codegen)) then usage (concat ["can't use ", @@ -1079,8 +1086,7 @@ System.system (gcc, List.concat - [targetOpts, - ["-o", output], + [["-o", output], if !debug then gccDebug else [], inputs, linkOpts])) @@ -1128,8 +1134,7 @@ System.system (gcc, List.concat - [targetOpts, - [ "-std=gnu99", "-c" ], + [[ "-std=gnu99", "-c" ], if !debug then debugSwitches else [], ccOpts, ["-o", output], @@ -1144,8 +1149,7 @@ System.system (gcc, List.concat - [targetOpts, - ["-c"], + [["-c"], if !debug then [asDebug] else [], asOpts, ["-o", output], Modified: mlton/trunk/runtime/Makefile =================================================================== --- mlton/trunk/runtime/Makefile 2008-02-14 16:15:52 UTC (rev 6402) +++ mlton/trunk/runtime/Makefile 2008-02-14 17:04:57 UTC (rev 6403) @@ -9,13 +9,24 @@ PATH := ../bin:$(shell echo $$PATH) TARGET := self + +ifeq ($(TARGET), self) +CC := gcc -std=gnu99 +AR := ar rc +RANLIB := ranlib +else +CC := $(TARGET)-gcc -std=gnu99 +AR := $(TARGET)-ar rc +RANLIB := $(TARGET)-ranlib +endif + TARGET_ARCH := $(shell ../bin/host-arch) TARGET_OS := $(shell ../bin/host-os) GCC_MAJOR_VERSION := \ - $(shell gcc -v 2>&1 | grep 'gcc version' | \ + $(shell $(CC) -v 2>&1 | grep 'gcc version' | \ sed 's/.*gcc version \([0-9][0-9]*\)\.\([0-9][0-9]*\).*/\1/') GCC_MINOR_VERSION := \ - $(shell gcc -v 2>&1 | grep 'gcc version' | \ + $(shell $(CC) -v 2>&1 | grep 'gcc version' | \ sed 's/.*gcc version \([0-9][0-9]*\)\.\([0-9][0-9]*\).*/\2/') GCC_VERSION := $(GCC_MAJOR_VERSION).$(GCC_MINOR_VERSION) @@ -94,16 +105,6 @@ FLAGS += -funroll-all-loops endif -ifeq ($(TARGET), self) -AR := ar rc -RANLIB := ranlib -else -AR := $(TARGET)-ar rc -RANLIB := $(TARGET)-ranlib -FLAGS += -b $(TARGET) -endif - -CC := gcc -std=gnu99 CPPFLAGS := CFLAGS := -I. -Iplatform $(FLAGS) OPTCFLAGS := $(CFLAGS) $(CPPFLAGS) $(OPTFLAGS) |
From: Matthew F. <fl...@ml...> - 2008-02-14 08:15:54
|
Use sharing constraints rather than where constraints ---------------------------------------------------------------------- U mlton/trunk/mlton/ast/ast-core.sig U mlton/trunk/mlton/core-ml/core-ml.sig ---------------------------------------------------------------------- Modified: mlton/trunk/mlton/ast/ast-core.sig =================================================================== --- mlton/trunk/mlton/ast/ast-core.sig 2008-02-14 05:08:02 UTC (rev 6401) +++ mlton/trunk/mlton/ast/ast-core.sig 2008-02-14 16:15:52 UTC (rev 6402) @@ -173,10 +173,10 @@ sig type t datatype node = T of (Pat.t * Exp.t) vector - include WRAPPED - sharing type node' = node - sharing type obj = t - end where type t = Exp.match + include WRAPPED sharing type node' = node + sharing type obj = t + end + sharing type Exp.match = Match.t structure EbRhs: sig Modified: mlton/trunk/mlton/core-ml/core-ml.sig =================================================================== --- mlton/trunk/mlton/core-ml/core-ml.sig 2008-02-14 05:08:02 UTC (rev 6401) +++ mlton/trunk/mlton/core-ml/core-ml.sig 2008-02-14 16:15:52 UTC (rev 6402) @@ -175,7 +175,7 @@ val layout: t -> Layout.t end - where type t = Exp.dec + sharing type Exp.dec = Dec.t structure Program: sig |
From: Matthew F. <fl...@ml...> - 2008-02-13 21:08:04
|
Integrate Wesley Teprstra's address space patch: On AMD64, not all 64 bits are actually accessible to userspace applications. The CPU itself has a limit well below this, and win64 imposes further a limit of 43 bits. This would be academic except that MLton carefully tries to position its heap by trying to map at 32 locations linearly across the address space. Since all of the attempted address are larger than the maximum possible in 43 bits, this fails. On linux the failure is not so important because mmap(0) succeeds. However, this code has a purpose: to prevent fragmentation. In the distant future, this might matter again. The attached patch fixes this by introducing POINTER_BITS and ADDRESS_BITS (which is less than POINTER_BITS). POINTER_BITS is the number of bits in a pointer, and ADDRESS_BITS is how many of those are actually useful as an address. Also, checking the value of UINTPTR_MAX with UINT64_MAX is a preprocessor friendly and portable way to configure POINTER_BITS (the old code used a non-portable __WORDSIZE). Some changes from the original patch: * use COMPILE_TIME_ASSERT in cenv.h to validate POINTER_BITS and ADDRESS_BITS, rather than assert in gen-sizes.c. * only win64 limits user mode virtual memory addresses to 43bits; linux allows user mode virtual memory addresses to be 48bits; I'm not sure about other OSes, and gave them 40bits (won't make a practical difference). ---------------------------------------------------------------------- U mlton/trunk/runtime/cenv.h U mlton/trunk/runtime/gc/heap.c U mlton/trunk/runtime/gc/model.h U mlton/trunk/runtime/gc.h U mlton/trunk/runtime/platform/amd64.h U mlton/trunk/runtime/util/pointer.h ---------------------------------------------------------------------- Modified: mlton/trunk/runtime/cenv.h =================================================================== --- mlton/trunk/runtime/cenv.h 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/cenv.h 2008-02-14 05:08:02 UTC (rev 6401) @@ -116,6 +116,20 @@ #error unknown platform arch #endif +#ifndef POINTER_BITS +#if UINTPTR_MAX == UINT32_MAX +#define POINTER_BITS 32 +#elif UINTPTR_MAX == UINT64_MAX +#define POINTER_BITS 64 +#else +#error Platform did not set POINTER_BITS and could not guess it. +#endif +#endif + +#ifndef ADDRESS_BITS +#define ADDRESS_BITS POINTER_BITS +#endif + #include "gmp.h" COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_voidStar, @@ -124,5 +138,9 @@ sizeof(uintptr_t) == sizeof(size_t)); COMPILE_TIME_ASSERT(sizeof_uintptr_t__is__sizeof_ptrdiff_t, sizeof(uintptr_t) == sizeof(ptrdiff_t)); +COMPILE_TIME_ASSERT(sizeof_voidStar__is__pointer_bits, + sizeof(void*)*CHAR_BIT == POINTER_BITS); +COMPILE_TIME_ASSERT(address_bits__lte__pointer_bits, + ADDRESS_BITS <= POINTER_BITS); #endif /* _MLTON_CENV_H_ */ Modified: mlton/trunk/runtime/gc/heap.c =================================================================== --- mlton/trunk/runtime/gc/heap.c 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/gc/heap.c 2008-02-14 05:08:02 UTC (rev 6401) @@ -171,7 +171,12 @@ for (h->size = desiredSize; h->size >= minSize; h->size -= backoff) { const unsigned int countLog2 = 5; const unsigned int count = 0x1 << countLog2; - const size_t step = (size_t)0x1 << ((POINTER_SIZE * CHAR_BIT) - countLog2); + const size_t step = (size_t)0x1 << (ADDRESS_BITS - countLog2); +#if ADDRESS_BITS == POINTER_BITS + const size_t address_end = 0; +#else + const size_t address_end = (size_t)0x1 << ADDRESS_BITS; +#endif static bool direction = TRUE; unsigned int i; @@ -182,7 +187,11 @@ address = (size_t)i * step; if (direction) - address = (size_t)0x0 - address; + address = address_end - address; + /* Always use 0 in the last step. */ + if (i == count) + address = 0; + h->start = GC_mmapAnon ((pointer)address, h->size); if ((void*)-1 == h->start) h->start = (void*)NULL; Modified: mlton/trunk/runtime/gc/model.h =================================================================== --- mlton/trunk/runtime/gc/model.h 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/gc/model.h 2008-02-14 05:08:02 UTC (rev 6401) @@ -150,7 +150,7 @@ #define GC_MODEL_HEADER_SIZE 64 #define GC_MODEL_ARRLEN_SIZE 64 #else -#error GC_MODEL_* unspecified +#error GC_MODEL_* undefined #endif #define GC_MODEL_MINALIGN_SHIFT max(2, GC_MODEL_OBJPTR_SHIFT + 1) Modified: mlton/trunk/runtime/gc.h =================================================================== --- mlton/trunk/runtime/gc.h 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/gc.h 2008-02-14 05:08:02 UTC (rev 6401) @@ -15,19 +15,13 @@ typedef struct GC_state *GC_state; typedef GC_state GCState_t; -#if defined(__WORDSIZE) -#if __WORDSIZE == 32 +#if POINTER_BITS == 32 #define GC_MODEL_NATIVE32 -#elif __WORDSIZE == 64 +#elif POINTER_BITS == 64 #define GC_MODEL_NATIVE64 #else -#error unknown __WORDSIZE +#error POINTER_BITS not defined #endif -#elif defined(__LP64__) -#define GC_MODEL_NATIVE64 -#else -#define GC_MODEL_NATIVE32 -#endif #include "gc/debug.h" Modified: mlton/trunk/runtime/platform/amd64.h =================================================================== --- mlton/trunk/runtime/platform/amd64.h 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/platform/amd64.h 2008-02-14 05:08:02 UTC (rev 6401) @@ -1 +1,10 @@ #define MLton_Platform_Arch_host "amd64" + +#define POINTER_BITS 64 +#if (defined (__CYGWIN__) || defined (__MINGW32__)) +#define ADDRESS_BITS 43 +#elif (defined (__linux__)) +#define ADDRESS_BITS 48 +#else +#define ADDRESS_BITS 40 +#endif Modified: mlton/trunk/runtime/util/pointer.h =================================================================== --- mlton/trunk/runtime/util/pointer.h 2008-02-14 04:53:11 UTC (rev 6400) +++ mlton/trunk/runtime/util/pointer.h 2008-02-14 05:08:02 UTC (rev 6401) @@ -11,19 +11,12 @@ typedef unsigned char pointerAux __attribute__ ((aligned (4), may_alias)); typedef pointerAux* pointer; -#define POINTER_SIZE sizeof(pointer) -#if defined(__WORDSIZE) -#if __WORDSIZE == 32 +#if POINTER_BITS == 32 #define FMTPTR "0x%08"PRIxPTR -#elif __WORDSIZE == 64 +#elif POINTER_BITS == 64 #define FMTPTR "0x%016"PRIxPTR #else -#error __WORDSIZE unknown +#error POINTER_BITS undefined #endif -#elif defined(__LP64__) -#define FMTPTR "0x%016"PRIxPTR -#else -#define FMTPTR "0x%08"PRIxPTR -#endif typedef const unsigned char* code_pointer; |
From: Matthew F. <fl...@ml...> - 2008-02-13 20:53:12
|
Regularize cpp error ---------------------------------------------------------------------- U mlton/trunk/runtime/bytecode/interpret.c ---------------------------------------------------------------------- Modified: mlton/trunk/runtime/bytecode/interpret.c =================================================================== --- mlton/trunk/runtime/bytecode/interpret.c 2008-02-14 04:52:17 UTC (rev 6399) +++ mlton/trunk/runtime/bytecode/interpret.c 2008-02-14 04:53:11 UTC (rev 6400) @@ -46,7 +46,7 @@ #define WordPointer Word64 #define WordArrayIndex Word64 #else -#error GC_MODEL_* unspecified +#error GC_MODEL_* undefined #endif typedef WordArrayIndex ArrayIndex; |
From: Matthew F. <fl...@ml...> - 2008-02-13 20:52:19
|
Typo and formatting in comment ---------------------------------------------------------------------- U mlton/trunk/runtime/gc/int-inf.c ---------------------------------------------------------------------- Modified: mlton/trunk/runtime/gc/int-inf.c =================================================================== --- mlton/trunk/runtime/gc/int-inf.c 2008-02-14 02:04:42 UTC (rev 6398) +++ mlton/trunk/runtime/gc/int-inf.c 2008-02-14 04:52:17 UTC (rev 6399) @@ -67,8 +67,8 @@ space[i] = (mp_limb_t)arg; // The conditional below is to quell a gcc warning: // right shift count >= width of type - // When 1 == LIMBS_PEROBJPTR, the for loop will not continue, so the - // shift doesn't matter. + // When 1 == LIMBS_PER_OBJPTR, the for loop will not continue, + // so the shift doesn't matter. arg = arg >> (1 == LIMBS_PER_OBJPTR ? 0 : CHAR_BIT * sizeof(mp_limb_t)); |