1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
|
(*
Title: Foreign Function Interface: memory operations
Author: David Matthews
Copyright David Matthews 2015
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License version 2.1 as published by the Free Software Foundation.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
structure ForeignMemory :>
sig
eqtype volatileRef
val volatileRef: SysWord.word -> volatileRef
val setVolatileRef: volatileRef * SysWord.word -> unit
val getVolatileRef: volatileRef -> SysWord.word
eqtype voidStar
val voidStar2Sysword: voidStar -> SysWord.word
val sysWord2VoidStar: SysWord.word -> voidStar
val null: voidStar
val ++ : voidStar * word -> voidStar
val -- : voidStar * word -> voidStar
(* Remember an address except across loads. *)
val memoise: ('a -> voidStar) ->'a -> unit -> voidStar
exception Memory
(* malloc - allocate memory. N.B. argument is the number of bytes.
Raises Memory exception if it cannot allocate. *)
val malloc: word -> voidStar
(* free - free allocated memory. *)
val free: voidStar -> unit
val get8: voidStar * Word.word -> Word8.word
val get16: voidStar * Word.word -> Word.word
val get32: voidStar * Word.word -> Word32.word
val get64: voidStar * Word.word -> SysWord.word
val set8: voidStar * Word.word * Word8.word -> unit
val set16: voidStar * Word.word * Word.word -> unit
val set32: voidStar * Word.word * Word32.word -> unit
val set64: voidStar * Word.word * SysWord.word -> unit
val getFloat: voidStar * Word.word -> real
val getDouble: voidStar * Word.word -> real
val setFloat: voidStar * Word.word * real -> unit
val setDouble: voidStar * Word.word * real -> unit
val getAddress: voidStar * Word.word -> voidStar
val setAddress: voidStar * Word.word * voidStar -> unit
end
=
struct
open ForeignConstants
open ForeignMemory
exception Foreign = RunCall.Foreign
fun id x = x
(* Internal utility function. *)
fun alignUp(s, align) = Word.andb(s + align-0w1, ~ align)
(* Both volatileRef and SysWord.word are the ADDRESSes of the actual value. *)
type volatileRef = word ref
val memMove: SysWord.word * SysWord.word * word * word* word -> unit = RunCall.moveBytes
fun volatileRef init =
let
(* Allocate a single word marked as mutable, weak, no-overwrite, byte. *)
(* A weak byte cell is cleared to zero when it is read in either from the
executable or from a saved state. Using the no-overwrite bit ensures
that if it is contained in the executable it won't be changed by loading
a saved state but there's a problem if it is contained in a parent state.
Then loading a child state will clear it because we reload all the parents
when we load a child. *)
val v = RunCall.allocateWordMemory(0w1, 0wx69, 0w0)
(* Copy the SysWord into it. *)
val () = memMove(init, RunCall.unsafeCast v, 0w0, 0w0, wordSize)
in
v
end
fun setVolatileRef(v, i) = memMove(i, RunCall.unsafeCast v, 0w0, 0w0, wordSize)
fun getVolatileRef var =
let
(* Allocate a single word marked as mutable, byte. *)
val v = RunCall.allocateByteMemory(0w1, 0wx41)
val () = memMove(RunCall.unsafeCast var, v, 0w0, 0w0, wordSize)
val () = RunCall.clearMutableBit v
in
v
end
type voidStar = SysWord.word
val voidStar2Sysword = id and sysWord2VoidStar = id (* Exported conversions *)
val null: voidStar = 0w0
infix 6 ++ --
fun s ++ w = s + SysWord.fromLarge(Word.toLarge w)
and s -- w = s - SysWord.fromLarge(Word.toLarge w)
fun 'a memoise(f: 'a -> voidStar) (a: 'a) : unit -> voidStar =
let
(* Initialise to zero. That means the function won't be
executed until we actually want the result. *)
val v = volatileRef 0w0
in
(* If we've reloaded the volatile ref it will have been reset to zero.
We need to execute the function and set it. *)
fn () => (case getVolatileRef v of 0w0 => let val r = f a in setVolatileRef(v, r); r end | r => r)
end
exception Memory
(* Get and set addresses. This is a bit messy because it has to compile on 64-bits as well as 32-bits. *)
val getAddress: voidStar * Word.word -> voidStar =
if wordSize = 0w4 then Word32.toLargeWord o get32 else get64
val setAddress: voidStar * Word.word * voidStar -> unit =
if wordSize = 0w4 then fn (s, i, v) => set32(s, i, Word32.fromLargeWord v) else set64
local
local
val ffiGeneralCall = RunCall.rtsCallFull2 "PolyFFIGeneral"
in
fun ffiGeneral(code: int, arg: 'a): 'b = RunCall.unsafeCast(ffiGeneralCall(RunCall.unsafeCast(code, arg)))
end
fun systemMalloc (s: word): voidStar = ffiGeneral (0, s)
(*fun systemFree (s: voidStar): unit = ffiGeneral (1, s)*)
(* Simple malloc/free implementation to reduce the number of RTS calls needed. *)
val lock = Thread.Mutex.mutex()
(* It would be possible to chain the free list in the C memory
itself. For the moment we don't do that.
The free list is the list of chunks ordered by increasing
address. That allows us to merge adjacent free blocks. *)
val freeList: {address: SysWord.word, size: word} list ref = LibrarySupport.noOverwriteRef nil
(* Clear it once on entry. *)
val () = PolyML.onEntry (fn _ => freeList := nil)
(* Assume that if we align to the maximum of these we're all right. *)
val maxAlign = Word.max(#align saDouble, Word.max(#align saPointer, #align saSint64))
(* We need a length word in each object we allocate but we need enough
padding to align the result. *)
val overhead = alignUp(wordSize, maxAlign)
val chunkSize = 0w4096 (* Configure this. *)
fun addFree(entry, []) = [entry]
| addFree(entry, this :: rest) =
if #address entry < #address this
then
(
if #address entry ++ #size entry = #address this
then (* New entry is immediately before old one - merge. *)
{address= #address entry, size = #size entry + #size this } :: rest
else entry :: this :: rest
)
else if #address this ++ #size this = #address entry
then (* New entry is immediately after this - merge. Continue because it could
also merge with an entry after this as well. *)
addFree({address= #address this, size= #size entry + #size this}, rest)
else this :: addFree(entry, rest) (* Search on. *)
(* Find free space. *)
fun findFree (_, []) = (NONE, [])
| findFree (space, (this as {size, address}) :: tl) =
if space = size
then (SOME address, tl)
else if space < size
then (SOME address, {size=size-space, address=address ++ space} :: tl)
else
let
val (res, rest) = findFree(space, tl)
in
(res, this :: rest)
end
fun freeMem s =
let
val addr = s -- overhead
val size = Word.fromLarge(SysWord.toLarge(getAddress(addr, 0w0)))
in
freeList := addFree({address=addr, size=size}, !freeList)
end
fun allocMem s =
let
val space = alignUp(s + overhead, maxAlign)
val (found, newList) = findFree(space, !freeList)
in
case found of
NONE =>
let
(* Need more memory *)
val requestSpace = Word.max(chunkSize, space)
val newSpace = systemMalloc requestSpace
val _ = newSpace <> null orelse raise Memory
in
(* Add the space to the free list in the appropriate place. *)
freeList := addFree({address=newSpace, size=requestSpace}, !freeList);
allocMem s (* Repeat - should succeed now. *)
end
| SOME address =>
let
val () = freeList := newList (* Update the free list *)
(* Store the length in the first word. *)
val () = setAddress(address, 0w0, SysWord.fromLarge(Word.toLarge space))
in
address ++ overhead
end
end
in
val malloc: word -> voidStar = ThreadLib.protect lock allocMem
fun free v = if v = null then () else ThreadLib.protect lock freeMem v
end
end;
|
