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