[hcoop/debian/mlton.git] / basis-library / real / pack-real.sml

(* Copyright (C) 2017 Matthew Fluet.
 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 * Copyright (C) 1997-2000 NEC Research Institute.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor PackRealArg (S: sig
                           type real
                           type word
                           val subArr: Word8.word array * SeqIndex.int -> word
                           val subVec: Word8.word vector * SeqIndex.int -> word
                           val update: Word8.word array * SeqIndex.int * word -> unit
                           val bswap: word -> word
                           val castFromWord: word -> real
                           val castToWord: real -> word
                        end) =
struct

open S

val subArrRev = castFromWord o bswap o subArr
val subVecRev = castFromWord o bswap o subVec
fun updateRev (a, i, r) = update (a, i, bswap (castToWord r))

val subArr = castFromWord o subArr
val subVec = castFromWord o subVec
val update = fn (a, i, r) => update (a, i, castToWord r)

end

structure PackReal32Arg =
   PackRealArg (open Primitive.PackReal32
                open Primitive.PackWord32
                val bswap = Word32.bswap)
structure PackReal64Arg =
   PackRealArg (open Primitive.PackReal64
                open Primitive.PackWord64
                val bswap = Word64.bswap)
structure PackRealArg =
   struct
      type real = Real.real
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = int
             val fReal32 = Real32.realSize
             val fReal64 = Real64.realSize)
      in
         val realSize = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subArr
             val fReal64 = PackReal64Arg.subArr)
      in
         val subArr = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word vector * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subVec
             val fReal64 = PackReal64Arg.subVec)
      in
         val subVec = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
             val fReal32 = PackReal32Arg.update
             val fReal64 = PackReal64Arg.update)
      in
         val update = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subArrRev
             val fReal64 = PackReal64Arg.subArrRev)
      in
         val subArrRev = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word vector * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subVecRev
             val fReal64 = PackReal64Arg.subVecRev)
      in
         val subVecRev = S.f
      end
      local
         structure S =
            Real_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
             val fReal32 = PackReal32Arg.updateRev
             val fReal64 = PackReal64Arg.updateRev)
      in
         val updateRev = S.f
      end
   end
structure PackLargeRealArg =
   struct
      type real = LargeReal.real
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = int
             val fReal32 = Real32.realSize
             val fReal64 = Real64.realSize)
      in
         val realSize = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subArr
             val fReal64 = PackReal64Arg.subArr)
      in
         val subArr = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word vector * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subVec
             val fReal64 = PackReal64Arg.subVec)
      in
         val subVec = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
             val fReal32 = PackReal32Arg.update
             val fReal64 = PackReal64Arg.update)
      in
         val update = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subArrRev
             val fReal64 = PackReal64Arg.subArrRev)
      in
         val subArrRev = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word vector * SeqIndex.int -> 'a
             val fReal32 = PackReal32Arg.subVecRev
             val fReal64 = PackReal64Arg.subVecRev)
      in
         val subVecRev = S.f
      end
      local
         structure S =
            LargeReal_ChooseRealN
            (type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
             val fReal32 = PackReal32Arg.updateRev
             val fReal64 = PackReal64Arg.updateRev)
      in
         val updateRev = S.f
      end
   end

functor PackReal (S: sig
                        type real
                        val realSize: int
                        val isBigEndian: bool
                        val subArr: Word8.word array * SeqIndex.int -> real
                        val subVec: Word8.word vector * SeqIndex.int -> real
                        val update: Word8.word array * SeqIndex.int * real -> unit
                        val subArrRev: Word8.word array * SeqIndex.int -> real
                        val subVecRev: Word8.word vector * SeqIndex.int -> real
                        val updateRev: Word8.word array * SeqIndex.int * real -> unit
                     end): PACK_REAL_EXTRA =
struct

open S

val bytesPerElem = Int.div (realSize, 8)

fun offset (i, n) = 
   let
      val i' = Int.* (bytesPerElem, i)
      val () =
         if Primitive.Controls.safe
            andalso (Int.geu (Int.+ (i', Int.- (bytesPerElem, 1)), n))
            then raise Subscript
            else ()
   in
      SeqIndex.fromInt i
   end
   handle Overflow => raise Subscript


val (subA, subV, updA) =
   if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian
      then (subArr, subVec, update)
   else (subArrRev, subVecRev, updateRev)

fun update (a, i, r) =
   let
      val i = offset (i, Word8Array.length a)
      val a = Word8Array.toPoly a
   in
      updA (a, i, r)
   end

fun unsafeUpdate (a, i, r) =
   let
      val i = SeqIndex.fromInt i
      val a = Word8Array.toPoly a
   in
      updA (a, i, r)
   end

local
   fun make (sub, length, toPoly) (av, i) =
      let
         val i = offset (i, length av)
      in
         sub (toPoly av, i)
      end
in
   val subArr = make (subA, Word8Array.length, Word8Array.toPoly)
   val subVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
end

local
   fun make (sub, length, toPoly) (av, i) =
      let
         val i = SeqIndex.fromInt i
      in
         sub (toPoly av, i)
      end
in
   val unsafeSubArr = make (subA, Word8Array.length, Word8Array.toPoly)
   val unsafeSubVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
end

fun toBytes (r: real): Word8Vector.vector =
   let
      val a = Array.alloc bytesPerElem
   in
      (updA (a, 0, r)
       ; Word8Vector.fromPoly (Array.vector a))
   end

fun fromBytes v = subVec (v, 0)

end

structure PackReal32Big: PACK_REAL_EXTRA =
   PackReal (open Real32
             open PackReal32Arg
             val isBigEndian = true)
structure PackReal32Little: PACK_REAL_EXTRA =
   PackReal (open Real32
             open PackReal32Arg
             val isBigEndian = false)
structure PackReal32Host: PACK_REAL_EXTRA =
   PackReal (open Real32
             open PackReal32Arg
             val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
structure PackReal64Big: PACK_REAL_EXTRA =
   PackReal (open Real64
             open PackReal64Arg
             val isBigEndian = true)
structure PackReal64Little: PACK_REAL_EXTRA =
   PackReal (open Real64
             open PackReal64Arg
             val isBigEndian = false)
structure PackReal64Host: PACK_REAL_EXTRA =
   PackReal (open Real64
             open PackReal64Arg
             val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
structure PackRealBig: PACK_REAL_EXTRA =
   PackReal (open Real
             open PackRealArg
             val isBigEndian = true)
structure PackRealLittle: PACK_REAL_EXTRA =
   PackReal (open Real
             open PackRealArg
             val isBigEndian = false)
structure PackRealHost: PACK_REAL_EXTRA =
   PackReal (open Real
             open PackRealArg
             val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
structure PackLargeRealBig: PACK_REAL_EXTRA =
   PackReal (open LargeReal
             open PackLargeRealArg
             val isBigEndian = true)
structure PackLargeRealLittle: PACK_REAL_EXTRA =
   PackReal (open LargeReal
             open PackLargeRealArg
             val isBigEndian = false)
structure PackLargeRealHost: PACK_REAL_EXTRA =
   PackReal (open LargeReal
             open PackLargeRealArg
             val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2017 Matthew Fluet.
	2	* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	* Copyright (C) 1997-2000 NEC Research Institute.
	5	*
	6	* MLton is released under a BSD-style license.
	7	* See the file MLton-LICENSE for details.
	8	*)
	9
	10	functor PackRealArg (S: sig
	11	type real
	12	type word
	13	val subArr: Word8.word array * SeqIndex.int -> word
	14	val subVec: Word8.word vector * SeqIndex.int -> word
	15	val update: Word8.word array * SeqIndex.int * word -> unit
	16	val bswap: word -> word
	17	val castFromWord: word -> real
	18	val castToWord: real -> word
	19	end) =
	20	struct
	21
	22	open S
	23
	24	val subArrRev = castFromWord o bswap o subArr
	25	val subVecRev = castFromWord o bswap o subVec
	26	fun updateRev (a, i, r) = update (a, i, bswap (castToWord r))
	27
	28	val subArr = castFromWord o subArr
	29	val subVec = castFromWord o subVec
	30	val update = fn (a, i, r) => update (a, i, castToWord r)
	31
	32	end
	33
	34	structure PackReal32Arg =
	35	PackRealArg (open Primitive.PackReal32
	36	open Primitive.PackWord32
	37	val bswap = Word32.bswap)
	38	structure PackReal64Arg =
	39	PackRealArg (open Primitive.PackReal64
	40	open Primitive.PackWord64
	41	val bswap = Word64.bswap)
	42	structure PackRealArg =
	43	struct
	44	type real = Real.real
	45	local
	46	structure S =
	47	Real_ChooseRealN
	48	(type 'a t = int
	49	val fReal32 = Real32.realSize
	50	val fReal64 = Real64.realSize)
	51	in
	52	val realSize = S.f
	53	end
	54	local
	55	structure S =
	56	Real_ChooseRealN
	57	(type 'a t = Word8.word array * SeqIndex.int -> 'a
	58	val fReal32 = PackReal32Arg.subArr
	59	val fReal64 = PackReal64Arg.subArr)
	60	in
	61	val subArr = S.f
	62	end
	63	local
	64	structure S =
65	Real_ChooseRealN
66	(type 'a t = Word8.word vector * SeqIndex.int -> 'a
67	val fReal32 = PackReal32Arg.subVec
68	val fReal64 = PackReal64Arg.subVec)
69	in
70	val subVec = S.f
71	end
72	local
73	structure S =
74	Real_ChooseRealN
75	(type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
76	val fReal32 = PackReal32Arg.update
77	val fReal64 = PackReal64Arg.update)
78	in
79	val update = S.f
80	end
81	local
82	structure S =
83	Real_ChooseRealN
84	(type 'a t = Word8.word array * SeqIndex.int -> 'a
85	val fReal32 = PackReal32Arg.subArrRev
86	val fReal64 = PackReal64Arg.subArrRev)
87	in
88	val subArrRev = S.f
89	end
90	local
91	structure S =
92	Real_ChooseRealN
93	(type 'a t = Word8.word vector * SeqIndex.int -> 'a
94	val fReal32 = PackReal32Arg.subVecRev
95	val fReal64 = PackReal64Arg.subVecRev)
96	in
97	val subVecRev = S.f
98	end
99	local
100	structure S =
101	Real_ChooseRealN
102	(type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
103	val fReal32 = PackReal32Arg.updateRev
104	val fReal64 = PackReal64Arg.updateRev)
105	in
106	val updateRev = S.f
107	end
108	end
109	structure PackLargeRealArg =
110	struct
111	type real = LargeReal.real
112	local
113	structure S =
114	LargeReal_ChooseRealN
115	(type 'a t = int
116	val fReal32 = Real32.realSize
117	val fReal64 = Real64.realSize)
118	in
119	val realSize = S.f
120	end
121	local
122	structure S =
123	LargeReal_ChooseRealN
124	(type 'a t = Word8.word array * SeqIndex.int -> 'a
125	val fReal32 = PackReal32Arg.subArr
126	val fReal64 = PackReal64Arg.subArr)
127	in
128	val subArr = S.f
129	end
130	local
131	structure S =
132	LargeReal_ChooseRealN
133	(type 'a t = Word8.word vector * SeqIndex.int -> 'a
134	val fReal32 = PackReal32Arg.subVec
135	val fReal64 = PackReal64Arg.subVec)
136	in
137	val subVec = S.f
138	end
139	local
140	structure S =
141	LargeReal_ChooseRealN
142	(type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
143	val fReal32 = PackReal32Arg.update
144	val fReal64 = PackReal64Arg.update)
145	in
146	val update = S.f
147	end
148	local
149	structure S =
150	LargeReal_ChooseRealN
151	(type 'a t = Word8.word array * SeqIndex.int -> 'a
152	val fReal32 = PackReal32Arg.subArrRev
153	val fReal64 = PackReal64Arg.subArrRev)
154	in
155	val subArrRev = S.f
156	end
157	local
158	structure S =
159	LargeReal_ChooseRealN
160	(type 'a t = Word8.word vector * SeqIndex.int -> 'a
161	val fReal32 = PackReal32Arg.subVecRev
162	val fReal64 = PackReal64Arg.subVecRev)
163	in
164	val subVecRev = S.f
165	end
166	local
167	structure S =
168	LargeReal_ChooseRealN
169	(type 'a t = Word8.word array * SeqIndex.int * 'a -> unit
170	val fReal32 = PackReal32Arg.updateRev
171	val fReal64 = PackReal64Arg.updateRev)
172	in
173	val updateRev = S.f
174	end
175	end
176
177	functor PackReal (S: sig
178	type real
179	val realSize: int
180	val isBigEndian: bool
181	val subArr: Word8.word array * SeqIndex.int -> real
182	val subVec: Word8.word vector * SeqIndex.int -> real
183	val update: Word8.word array * SeqIndex.int * real -> unit
184	val subArrRev: Word8.word array * SeqIndex.int -> real
185	val subVecRev: Word8.word vector * SeqIndex.int -> real
186	val updateRev: Word8.word array * SeqIndex.int * real -> unit
187	end): PACK_REAL_EXTRA =
188	struct
189
190	open S
191
192	val bytesPerElem = Int.div (realSize, 8)
193
194	fun offset (i, n) =
195	let
196	val i' = Int.* (bytesPerElem, i)
197	val () =
198	if Primitive.Controls.safe
199	andalso (Int.geu (Int.+ (i', Int.- (bytesPerElem, 1)), n))
200	then raise Subscript
201	else ()
202	in
203	SeqIndex.fromInt i
204	end
205	handle Overflow => raise Subscript
206
207
208	val (subA, subV, updA) =
209	if isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian
210	then (subArr, subVec, update)
211	else (subArrRev, subVecRev, updateRev)
212
213	fun update (a, i, r) =
214	let
215	val i = offset (i, Word8Array.length a)
216	val a = Word8Array.toPoly a
217	in
218	updA (a, i, r)
219	end
220
221	fun unsafeUpdate (a, i, r) =
222	let
223	val i = SeqIndex.fromInt i
224	val a = Word8Array.toPoly a
225	in
226	updA (a, i, r)
227	end
228
229	local
230	fun make (sub, length, toPoly) (av, i) =
231	let
232	val i = offset (i, length av)
233	in
234	sub (toPoly av, i)
235	end
236	in
237	val subArr = make (subA, Word8Array.length, Word8Array.toPoly)
238	val subVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
239	end
240
241	local
242	fun make (sub, length, toPoly) (av, i) =
243	let
244	val i = SeqIndex.fromInt i
245	in
246	sub (toPoly av, i)
247	end
248	in
249	val unsafeSubArr = make (subA, Word8Array.length, Word8Array.toPoly)
250	val unsafeSubVec = make (subV, Word8Vector.length, Word8Vector.toPoly)
251	end
252
253	fun toBytes (r: real): Word8Vector.vector =
254	let
255	val a = Array.alloc bytesPerElem
256	in
257	(updA (a, 0, r)
258	; Word8Vector.fromPoly (Array.vector a))
259	end
260
261	fun fromBytes v = subVec (v, 0)
262
263	end
264
265	structure PackReal32Big: PACK_REAL_EXTRA =
266	PackReal (open Real32
267	open PackReal32Arg
268	val isBigEndian = true)
269	structure PackReal32Little: PACK_REAL_EXTRA =
270	PackReal (open Real32
271	open PackReal32Arg
272	val isBigEndian = false)
273	structure PackReal32Host: PACK_REAL_EXTRA =
274	PackReal (open Real32
275	open PackReal32Arg
276	val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
277	structure PackReal64Big: PACK_REAL_EXTRA =
278	PackReal (open Real64
279	open PackReal64Arg
280	val isBigEndian = true)
281	structure PackReal64Little: PACK_REAL_EXTRA =
282	PackReal (open Real64
283	open PackReal64Arg
284	val isBigEndian = false)
285	structure PackReal64Host: PACK_REAL_EXTRA =
286	PackReal (open Real64
287	open PackReal64Arg
288	val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
289	structure PackRealBig: PACK_REAL_EXTRA =
290	PackReal (open Real
291	open PackRealArg
292	val isBigEndian = true)
293	structure PackRealLittle: PACK_REAL_EXTRA =
294	PackReal (open Real
295	open PackRealArg
296	val isBigEndian = false)
297	structure PackRealHost: PACK_REAL_EXTRA =
298	PackReal (open Real
299	open PackRealArg
300	val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)
301	structure PackLargeRealBig: PACK_REAL_EXTRA =
302	PackReal (open LargeReal
303	open PackLargeRealArg
304	val isBigEndian = true)
305	structure PackLargeRealLittle: PACK_REAL_EXTRA =
306	PackReal (open LargeReal
307	open PackLargeRealArg
308	val isBigEndian = false)
309	structure PackLargeRealHost: PACK_REAL_EXTRA =
310	PackReal (open LargeReal
311	open PackLargeRealArg
312	val isBigEndian = Primitive.MLton.Platform.Arch.hostIsBigEndian)