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