diff --git a/basis/ExnPrinter.581.sml b/basis/ExnPrinter.581.sml deleted file mode 100644 index c04418dc..00000000 --- a/basis/ExnPrinter.581.sml +++ /dev/null @@ -1,122 +0,0 @@ -(* - Title: Install a pretty printer for the exn type - Author: David Matthews - Copyright David Matthews 2009, 2016, 2019 - - 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 -*) -local - open PolyML - (* Print exception packet. Run-time system exceptions have - to be processed specially because the IDs don't have printer functions. *) - fun exnPrint depth _ exn = - let - val (exnId, exnName, exnArg, _) = RunCall.unsafeCast exn - - (* This parenthesis code is used in various places and probably should be centralised. *) - fun parenthesise(s as PrettyBlock(_, _, _, [ _ ])) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("(")::_ ))) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("{")::_ ))) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("[")::_ ))) = s - | parenthesise(s as PrettyBlock _) = - PrettyBlock(3, true, [], [ PrettyString "(", s, PrettyString ")" ]) - | parenthesise s = s (* String or Break *) - - fun nullaryException s = PrettyString s - and parameterException(s, param) = - PrettyBlock(1, false, [], - [ - PrettyString s, - PrettyBreak(1, 1), - parenthesise param - ]) - (* Use prettyRepresentation because this correctly quotes the string. *) - fun stringException(s, arg: string) = - parameterException(s, PolyML.prettyRepresentation(arg, depth-1)) - in - if RunCall.isShort exnId - then - case exn of - RunCall.Conversion s => stringException(exnName, s) - | Fail s => stringException(exnName, s) - | RunCall.Foreign s => stringException(exnName, s) - | RunCall.Thread s => stringException(exnName, s) - | RunCall.XWindows s => stringException(exnName, s) - | LibrarySupport.SysErr param => - parameterException("SysErr", - if depth <= 1 then PrettyString "..." else PolyML.prettyRepresentation(param, depth-1)) - | _ => (* Anything else is nullary. *) - nullaryException exnName - else - ( - (* Exceptions generated within ML contain a printer function. *) - case !exnId of - NONE => nullaryException exnName - | SOME printFn => parameterException(exnName, printFn(exnArg, depth-1)) - ) - end -in - val () = addPrettyPrinter exnPrint -end; - -(* Print a ref. Because refs can form circular structures we include a check for a loop here. *) -local - open PolyML - (* If we have an expression as the argument we parenthesise it unless it is - a simple string, a tuple, a record or a list. *) - fun parenthesise(s as PrettyBlock(_, _, _, [ _ ])) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("(")::_ ))) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("{")::_ ))) = s - | parenthesise(s as PrettyBlock(_, _, _, (PrettyString("[")::_ ))) = s - | parenthesise(s as PrettyBlock _) = - PrettyBlock(3, true, [], [ PrettyString "(", s, PrettyString ")" ]) - | parenthesise s = s (* String or Break *) - - val printLimit: word ref list Universal.tag = Universal.tag() - - fun print_ref depth doArg (r as ref x) = - if depth <= 0 - then PrettyString "..." - else - let - (* We keep a list in thread-local storage of refs we're currently printing. - This is thread-local to avoid interference between different threads. *) - val currentRefs = - case Thread.Thread.getLocal printLimit of - NONE => [] - | SOME limit => limit - val thisRef: word ref = RunCall.unsafeCast r - in - if List.exists(fn x => x = thisRef) currentRefs - then PrettyString "..." (* We've already seen this ref. *) - else - ( - (* Add this to the list. *) - Thread.Thread.setLocal (printLimit, thisRef :: currentRefs); - (* Print it and reset the list*) - (PrettyBlock(3, false, [], - [ PrettyString "ref", PrettyBreak(1, 0), parenthesise(doArg(x, depth-1)) ])) - before (Thread.Thread.setLocal (printLimit, currentRefs)) - ) handle exn => - ( - (* Reset the list if there's been an exception. *) - Thread.Thread.setLocal (printLimit, currentRefs); - raise exn - ) - end - -in - val () = addPrettyPrinter print_ref -end; - diff --git a/basis/Foreign.581.sml b/basis/Foreign.581.sml deleted file mode 100644 index 6b2fc9a2..00000000 --- a/basis/Foreign.581.sml +++ /dev/null @@ -1,88 +0,0 @@ -(* - Title: Foreign Function Interface: main part - Author: David Matthews - Copyright David Matthews 2015-16, 2018, 2020 - - 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 -*) - -(* A subset of the main Foreign structure for booting. We need - memoise in the interpreter. *) - -structure Foreign = -struct - exception Foreign = RunCall.Foreign - - structure Memory :> - sig - eqtype volatileRef - val volatileRef: SysWord.word -> volatileRef - val setVolatileRef: volatileRef * SysWord.word -> unit - val getVolatileRef: volatileRef -> SysWord.word - - eqtype voidStar - (* Remember an address except across loads. *) - val memoise: ('a -> voidStar) ->'a -> unit -> voidStar - end - = - struct - open ForeignConstants - - (* 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(sysWordSize div wordSize, 0wx69, 0w0) - (* Copy the SysWord into it. *) - val () = memMove(init, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) - in - v - end - - fun setVolatileRef(v, i) = memMove(i, RunCall.unsafeCast v, 0w0, 0w0, sysWordSize) - - fun getVolatileRef var = - let - (* Allocate a single word marked as mutable, byte. *) - val v = RunCall.allocateByteMemory(sysWordSize div wordSize, 0wx41) - val () = memMove(RunCall.unsafeCast var, v, 0w0, 0w0, sysWordSize) - val () = RunCall.clearMutableBit v - in - v - end - - type voidStar = SysWord.word - - 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 - end -end; diff --git a/basis/ForeignMemory.581.sml b/basis/ForeignMemory.581.sml deleted file mode 100644 index fe56498f..00000000 --- a/basis/ForeignMemory.581.sml +++ /dev/null @@ -1,18 +0,0 @@ -(* - Title: Foreign Function Interface: memory operations - Author: David Matthews - Copyright David Matthews 2015, 2017, 2019 - - 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 -*) diff --git a/basis/InitialBasis.581.ML b/basis/InitialBasis.581.ML deleted file mode 100644 index 6fc6f603..00000000 --- a/basis/InitialBasis.581.ML +++ /dev/null @@ -1,458 +0,0 @@ -(* - Copyright (c) 2000-2010, 2016-17 David C.J. Matthews - - 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 -*) - -infix 7 * / div mod -infix 6 + - ^ -infixr 5 :: @ -infix 4 = <> > >= < <= -infix 3 := o -infix 0 before - -(* Include this for the moment. TODO: Check why Real, at any rate, requires - the "redundant" structure binding in order for the built-ins to be - properly inlined. *) -structure RunCall = -struct - open RunCall - (* This is included in 5.8.2 but not 5.8.1. It's needed for the interpreter. *) - fun rtsCallFull4 _ _ = raise Fail "rtsCallFull4 not implemented" -end; - -(* Types and values from the initial Bool structure. *) -datatype bool = datatype Bool.bool -val not = Bool.not; - - -(* Types and values from the initial FixedInt structure. *) -structure FixedInt = -struct - open FixedInt (* Inherit built-in functions. *) - - fun ~ (x: int): int = 0 - x - - fun abs (i: int): int = if i >= 0 then i else ~ i -end; - -val () = RunCall.addOverload FixedInt.>= ">=" -and () = RunCall.addOverload FixedInt.<= "<=" -and () = RunCall.addOverload FixedInt.> ">" -and () = RunCall.addOverload FixedInt.< "<" -and () = RunCall.addOverload FixedInt.+ "+" -and () = RunCall.addOverload FixedInt.- "-" -and () = RunCall.addOverload FixedInt.* "*" -and () = RunCall.addOverload FixedInt.~ "~" -and () = RunCall.addOverload FixedInt.abs "abs"; - -structure LargeInt = -struct - open LargeInt - - local - val callAdd: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyAddArbitrary" - and callSub: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolySubtractArbitrary" - and callMult: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyMultiplyArbitrary" - - (* Comparison does not need to allocate memory so is a fast call. *) - val callComp: LargeInt.int * LargeInt.int -> FixedInt.int = RunCall.rtsCallFast2 "PolyCompareArbitrary" - - exception Overflow = RunCall.Overflow - in - val op + = fn (i, j) => add(i, j, callAdd) - and op - = fn (i, j) => subtract(i, j, callSub) - and op * = fn (i, j) => multiply(i, j, callMult) - - val op < = fn (i, j) => less(i, j, callComp) - and op > = fn (i, j) => greater(i, j, callComp) - and op <= = fn (i, j) => lessEq(i, j, callComp) - and op >= = fn (i, j) => greaterEq(i, j, callComp) - - (* Negation. Just use 0 - X. *) - fun ~ x = 0 - x - end - - (* N.B. div and mod are added on a bit further down. *) -end; - -val () = RunCall.addOverload LargeInt.>= ">=" -and () = RunCall.addOverload LargeInt.<= "<=" -and () = RunCall.addOverload LargeInt.> ">" -and () = RunCall.addOverload LargeInt.< "<" -and () = RunCall.addOverload LargeInt.+ "+" -and () = RunCall.addOverload LargeInt.- "-" -and () = RunCall.addOverload LargeInt.* "*" -and () = RunCall.addOverload LargeInt.~ "~"; -(*and () = RunCall.addOverload LargeInt.abs "abs"*) - - -(* Now add div and mod. *) -local - (* There's some duplication. This is also in Int.sml. *) - local - fun power2' n 0 : LargeInt.int = n - | power2' n i = power2' (2*n) (i-1) - val power2 = power2' 1 - val wordSize : word = RunCall.bytesPerWord - val bitsInWord: int = (RunCall.unsafeCast wordSize) * 8 - val wordSize = bitsInWord - 1 (* 31 or 63 bits *) - in - val maxIntP1 = power2(wordSize-1) - end -in - structure FixedInt = - struct - open FixedInt - - local - val fquot: FixedInt.int * FixedInt.int -> FixedInt.int = quot - val frem: FixedInt.int * FixedInt.int -> FixedInt.int = rem - val smallestInt = RunCall.unsafeCast(LargeInt.~ maxIntP1) - infix 7 quot rem - exception Overflow = RunCall.Overflow - and Div = RunCall.Div - in - fun op quot(_, 0) = raise RunCall.Div - | op quot(x, y) = - if y = ~1 andalso x = smallestInt - then raise Overflow - else fquot(x,y) - - (* This should return zero when dividing minInt by ~1. Since we - are working with 31/63 bits this won't overflow and will return - the correct answer. *) - fun op rem(_, 0) = raise Div - | op rem(x, y) = frem (x, y) - - (* mod adjusts the result of rem to give the correcly signed result. *) - fun x mod y = - let - val remainder = x rem y - in - if remainder = 0 - then 0 (* If the remainder was zero the result is zero. *) - else if (remainder < 0) = (y < 0) - then remainder (* If the signs are the same there's no adjustment. *) - else remainder + y (* Have to add in the divisor. *) - end - - (* div adjusts the result to round towards -infinity. *) - fun x div y = - let - val quotient = x quot y (* raises Div or Overflow as appropriate. *) - and remainder = x rem y - in - if remainder = 0 orelse (remainder < 0) = (y < 0) - then quotient - else quotient-1 - end - end - - end; - - structure LargeInt = - struct - open LargeInt - - local - val isShort: LargeInt.int -> bool = RunCall.isShort - val toShort: LargeInt.int -> FixedInt.int = RunCall.unsafeCast - and fromShort: FixedInt.int -> LargeInt.int = RunCall.unsafeCast - - val callDiv: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyDivideArbitrary" - and callRem: LargeInt.int * LargeInt.int -> LargeInt.int = RunCall.rtsCallFull2 "PolyRemainderArbitrary" - and callQuotRem: LargeInt.int * LargeInt.int -> LargeInt.int * LargeInt.int = RunCall.rtsCallFull2 "PolyQuotRemArbitraryPair" - - infix 7 quot rem - - exception Overflow = RunCall.Overflow - val smallestInt = ~ maxIntP1 - - val zero = 0 - in - val op quot = - fn (_, 0) => raise RunCall.Div - | (i: int, j: int) => - if isShort i andalso isShort j andalso not (j = ~1 andalso i = smallestInt) - then fromShort(FixedInt.quot(toShort i, toShort j)) - else callDiv(i, j) - - (* We don't have to worry about overflow here because we will - get the correct result if we divide the smallest int by -1 and - because we're actually using 31/63 bits rather than true 32/64 bits - we won't get a hardware trap. *) - val op rem = - fn (_, 0) => raise RunCall.Div - | (i, j) => - if isShort i andalso isShort j - then fromShort(FixedInt.rem(toShort i, toShort j)) - else callRem(i, j) - - fun x mod y = - let - val r = x rem y - in - if r = zero orelse (y >= zero) = (r >= zero) then r else r + y - end - - fun x div y = - let - (* If the signs differ the normal quot operation will give the wrong - answer. We have to round the result down by subtracting either y-1 or - y+1. This will round down because it will have the opposite sign to x *) - - (* ... - val d = x - (if (y >= 0) = (x >= 0) then 0 else if y > 0 then y-1 else y+1) - ... *) - val xpos = x >= zero - val ypos = y >= zero - - val d = - if xpos = ypos - then x - else if ypos - then (x - (y - 1)) - else (x - (y + 1)) - in - d quot y (* may raise Div for divide-by-zero *) - end - - (* This should end up in IntInf not LargeInt so it gets picked up by LibrarySupport. *) - fun quotRem(i, j) = - if isShort i andalso isShort j andalso not (j = ~1 andalso i = smallestInt) - then (fromShort(FixedInt.quot(toShort i, toShort j)), fromShort(FixedInt.rem(toShort i, toShort j))) - else callQuotRem(i, j) - end - end; -end; - -val () = RunCall.addOverload FixedInt.div "div" -and () = RunCall.addOverload FixedInt.mod "mod" -and () = RunCall.addOverload LargeInt.div "div" -and () = RunCall.addOverload LargeInt.mod "mod"; - -structure Word = -struct - open Word - infix 8 << >> ~>> (* The shift operations are not infixed in the global basis. *) - - fun ~ x = 0w0 - x - - (* Redefine div and mod to include checks for zero. *) - fun op div(_, 0w0) = raise RunCall.Div | op div(x, y) = Word.div(x, y) - fun op mod(_, 0w0) = raise RunCall.Div | op mod(x, y) = Word.mod(x, y) - - local - val maxBits = RunCall.bytesPerWord * 0w8 - 0w1 - in - (* The X86 masks the shift value but ML defines a shift greater than the - word length as returning zero except that a negative number with an - arithmetic shift returns ~1. The tests will all be optimised away - if the shift is a constant. *) - val op << = fn (a, b) => if b >= maxBits then 0w0 else a << b - val op >> = fn (a, b) => if b >= maxBits then 0w0 else a >> b - val op ~>> = fn (a, b) => a ~>> (if b > maxBits then maxBits else b) - end - - val toLarge = toLargeWord and toLargeX = toLargeWordX and fromLarge = fromLargeWord -end; - -val () = RunCall.addOverload Word.>= ">=" -and () = RunCall.addOverload Word.<= "<=" -and () = RunCall.addOverload Word.> ">" -and () = RunCall.addOverload Word.< "<" -and () = RunCall.addOverload Word.+ "+" -and () = RunCall.addOverload Word.- "-" -and () = RunCall.addOverload Word.* "*" -and () = RunCall.addOverload Word.~ "~" -and () = RunCall.addOverload Word.div "div" -and () = RunCall.addOverload Word.mod "mod"; -(* N.B. abs is not overloaded on word *) - -structure LargeWord = -struct - open LargeWord - - local - infix 8 << >> ~>> (* The shift operations are not infixed in the global basis. *) - val zero = Word.toLargeWord 0w0 - (* As with Word.word shifts we have to check that the shift does not exceed the - word length. N.B. The shift amount is always a Word.word value. *) - (* This is the same as wordSize in native 32-bit and 64-bit but different in 32-in-64. *) - val sysWordSize = Word.*(RunCall.memoryCellLength zero, RunCall.bytesPerWord) - val maxBits = Word.*(sysWordSize, 0w8) (* 32 or 64-bits. *) - in - val wordSize = maxBits - val op << = fn (a, b) => if Word.>=(b, maxBits) then zero else a << b - val op >> = fn (a, b) => if Word.>=(b, maxBits) then zero else a >> b - val op ~>> = fn (a, b) => a ~>> (if Word.>(b, maxBits) then maxBits else b) - end - - local - val zero = Word.toLargeWord 0w0 - in - fun x div y = if y = zero then raise RunCall.Div else LargeWord.div(x, y) - and x mod y = if y = zero then raise RunCall.Div else LargeWord.mod(x, y) - end -end; - -(* We seem to need to have these apparently redundant structures to - make sure the built-ins are inlined. *) -structure Char = -struct - open Char -end; - -(* We want these overloads in String. *) -val () = RunCall.addOverload Char.>= ">=" -and () = RunCall.addOverload Char.<= "<=" -and () = RunCall.addOverload Char.> ">" -and () = RunCall.addOverload Char.< "<"; - -structure String = -struct - open String -end; - -(* Overloads for String are added in String.sml *) - -structure Real = -struct - open Real -end; - -val () = RunCall.addOverload Real.>= ">=" -and () = RunCall.addOverload Real.<= "<=" -and () = RunCall.addOverload Real.> ">" -and () = RunCall.addOverload Real.< "<" -and () = RunCall.addOverload Real.+ "+" -and () = RunCall.addOverload Real.- "-" -and () = RunCall.addOverload Real.* "*" -and () = RunCall.addOverload Real.~ "~" -and () = RunCall.addOverload Real.abs "abs" -and () = RunCall.addOverload Real./ "/"; - -structure ForeignMemory = -struct - open ForeignMemory - - (* Add wrappers to these functions so that they raise exceptions if they are called. *) - val get64 = - fn (s, i) => - if LargeWord.wordSize < 0w64 - then raise RunCall.Foreign "64-bit operations not available" else get64(s, i) - and set64 = - fn (s, i, v) => - if LargeWord.wordSize < 0w64 - then raise RunCall.Foreign "64-bit operations not available" else set64(s, i, v) -end; - -(* This needs to be defined for StringSignatures but must not be defined in - that file because that conflicts with building the IntAsIntInf module. *) -structure StringCvt = struct type ('a, 'b) reader = 'b -> ('a * 'b) option end; - - (* We need to use the same identifier for this that we used when - compiling the compiler, particularly "make". *) - exception Fail = RunCall.Fail - -(* A few useful functions which are in the top-level environment. - Others are added later. *) - -fun (var: 'a ref) := (v: 'a) : unit = RunCall.storeWord (var, 0w0, v) - -(* The following version of "o" currently gets optimised better. *) -fun (f o g) = fn x => f (g x); (* functional composition *) - -fun ! (ref x) = x; - -fun length l = - let - (* Tail-recursive function. *) - fun len [] i = i - | len (_::l) i = len l (i+1) - in - len l 0 - end - -local - (* Temporary conversion function for characters. This is replaced in - the Char structure. *) - fun convChar (s: string) : char = - let - val convS = Bootstrap.convString s - in - if true (*String.lengthWordAsWord convS = 0w1*) - then RunCall.loadByte(convS, RunCall.bytesPerWord) - else raise RunCall.Conversion "Bad character" - end -in - val it = RunCall.addOverload convChar "convChar"; -end; - -(* Print functions. Some of these are replaced by functions in the Basis library and - are installed here merely so that we can get useful output if we get a failure while - compiling it. *) -local - open PolyML - - fun print_bool _ _ (b: bool) = - PrettyString(if b then "true" else "false") - - fun print_string _ _ (s: string) = PrettyString s (* Not escaped at the moment. *) - - fun print_char _ _ (c: char) = - PrettyBlock (0, false, [], [PrettyString "#", PrettyString(RunCall.unsafeCast c)]) - - fun nil @ y = y (* This is redefined later. *) - | (a::b) @ y = a :: (b @ y) - - fun print_list depth printEl (l: 'a list) = - let - (* Print the list as [, , etc ]. Replace the - rest of the list by ... once the depth reaches zero. *) - fun plist [] _ = [] - | plist _ 0 = [PrettyString "..."] - | plist [h] depth = [printEl (h, depth)] - | plist (h::t) depth = - printEl (h, depth) :: - PrettyString "," :: - PrettyBreak (1, 0) :: - plist t (depth - 1) - - in - PrettyBlock (1, false, [], (* Wrap this in a begin-end block to keep it together. *) - PrettyString "[" :: - ((if depth <= 0 then [PrettyString "..."] else plist l depth) @ - [PrettyString "]"] - ) - ) - end - - fun print_int _ _ (i: int) = - let - fun pr (i: int) = - if i < 0 then PrettyString "~" :: pr (~ i) - else if i < 10 then [PrettyString(RunCall.unsafeCast(i + RunCall.unsafeCast #"0"))] - else pr(i div 10) @ [PrettyString(RunCall.unsafeCast(i mod 10 + 48))] - in - PrettyBlock(1, false, [], pr i) - end -in - val () = addPrettyPrinter print_bool - val () = addPrettyPrinter print_string - val () = addPrettyPrinter print_char - val () = addPrettyPrinter print_list - val () = addPrettyPrinter print_int -end; diff --git a/basis/Thread.581.sml b/basis/Thread.581.sml deleted file mode 100644 index 1cef1b6f..00000000 --- a/basis/Thread.581.sml +++ /dev/null @@ -1,768 +0,0 @@ -(* - Title: Thread package for ML. - Author: David C. J. Matthews - Copyright (c) 2007-2014, 2018-20 - - 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 -*) - -(* This signature and structure are not part of the standard basis library - but are included here because they depend on the Time structure and are - in turn dependencies of the BasicIO structure. *) - -(*!Earlier versions of Poly/ML have provided a form of concurrent execution through - the Process structure. Version 5.1 introduces - new thread primitives in the Thread structure. This structure is modelled on - the Posix thread (pthread) package but simplified and modified for ML. The aim - is to provide an efficient implementation of parallelism particularly to enable - ML programs to make use of multi-core processors while minimising the changes - needed to existing code. The Process structure will continue to be available - as a library written on top of these primitives but new programs should use - the Thread structure directly. - -The thread package differs from pthreads in a number of ways. -There is no join function to wait for the completion of a thread. -This can be written using mutexes and condition variables. -Cancellation and signal handling are combined into the interrupt -functions. (The Poly/ML Signal structure handles signals for all the -threads together). The effect of explicit cancellation is achieved -using the interrupt function. This causes an interrupt to be -generated in a specific thread. Alternatively an interrupt can be -broadcast to all threads. This is most likely to be used -interactively to kill threads that appear to have gone out of -control. The normal top-level handler for a console interrupt will -generate this. Threads can choose how or whether they respond to -these interrupts. A thread that is doing processor-intensive work -probably needs to be able to be interrupted asynchronously whereas if -it is communicating with other threads the presence of asynchronous -interrupts makes correct programming difficult. -*) - -signature THREAD = -sig - (*!The Thread exception can be raised by various of the functions in the - structure if they detect an error.*) - exception Thread of string (* Raised if an operation fails. *) - - structure Thread: - sig - (*!The type of a thread identifier.*) - eqtype thread - - (* Thread attributes - This may be extended. *) - (*!The type of a thread attribute. Thread attributes are - properties of the thread that are set initially when the thread is - created but can subsequently be modified by the thread itself. The - thread attribute type may be extended in the future to include things - like scheduling priority. The current thread attributes control the - way interrupt exceptions are delivered to the thread. - - `EnableBroadcastInterrupt` controls whether the thread will receive an interrupt sent using - `broadcastInterrupt` or as a result of pressing the console interrupt - key. If this is false the thread will not receive them. The default - for a new thread if this is not specified is false. - - `InterruptState` controls when and whether interrupts are delivered to the - thread. This includes broadcast interrupts and also interrupts directed at - a specific thread with the interrupt call. - `InterruptDefer` means the thread - will not receive any interrupts. However, if the thread has previously been - interrupted the interrupt may be delivered when the thread calls setAttributes - to change its interrupt state. `InterruptSynch` - means interrupts are delivered - synchronously. An interrupt will be delayed until an interruption point. An - interruption point is one of: `testInterrupt`, - `ConditionVar.wait`, `ConditionVar.waitUntil` - and various library calls that may block, such as IO calls, pause etc. N.B. - `Mutex.lock` is not an interruption point even though it can result in a thread - blocking for an indefinite period. `InterruptAsynch` means interrupts are delivered - asynchronously i.e. at a suitable point soon after they are triggered. - `InterruptAsynchOnce` - means that only a single interrupt is delivered asynchronously after which - the interrupt state is changed to `InterruptSynch`. It allows a thread to tidy - up and if necessary indicate that it has been interrupted without the risk - of a second asynchronous interrupt occurring in the handler for the first - interrupt. If this attribute is not specified when a thread is created the - default is `InterruptSynch`. - - `MaximumMLStack` was added in version 5.5.3. It controls the maximum size the - ML stack may grow to. It is an option type where NONE allows the stack to - grow to the limit of the available memory whereas SOME n limits the stack - to n words. This is approximate since there is some rounding involved. When - the limit is reached the thread is sent an Interrupt exception.*) - datatype threadAttribute = - (* Does this thread accept a broadcast interrupt? The default is not to - accept broadcast interrupts. *) - EnableBroadcastInterrupt of bool - (* How to handle interrupts. The default is to handle interrupts synchronously. *) - | InterruptState of interruptState - (* Maximum size of the ML stack in words. NONE means unlimited *) - | MaximumMLStack of int option - - and interruptState = - InterruptDefer (* Defer any interrupts. *) - | InterruptSynch (* Interrupts are delivered synchronously. An interrupt - will be delayed until an interruption point. An interruption point - is one of: testInterrupt, ConditionVar.wait, ConditionVar.waitUntil - and various library calls that may block, such as IO calls, pause etc. - N.B. Mutex.lock is not an interruption point even though it can result - in a thread blocking for an indefinite period. *) - | InterruptAsynch (* Interrupts are delivered asynchronously i.e. at a suitable - point soon after they are triggered. *) - | InterruptAsynchOnce (* As InterruptAsynch except that only a single interrupt - is delivered asynchronously after which the interrupt state is changed to - InterruptSynch. It allows a thread to tidy up and if necessary indicate - that it has been interrupted without the risk of a second asynchronous - interrupt occurring in the handler for the first interrupt. *) - - (*!Fork a thread. Starts a new thread running - the function argument. The attribute list gives initial values for thread attributes - which can be modified by the thread itself. Any unspecified attributes take - default values. The thread is terminated when the thread function returns, if - it raises an uncaught exception or if it calls `exit`;*) - val fork: (unit->unit) * threadAttribute list -> thread - - (*!Terminate this thread. *) - val exit: unit -> unit - (*!Test if a thread is still running or has terminated. This function should be - used with care. The thread may be on the point of terminating and still appear - to be active.*) - val isActive: thread -> bool - - (*!Test whether thread ids are the same. This is provided for backwards compatibility - since `thread` is an eqtype. *) - val equal: thread * thread -> bool - (*!Return the thread identifier for the current thread. *) - val self: unit -> thread - - exception Interrupt (* = SML90.Interrupt *) - (*!Send an Interrupt exception to a specific thread. When and indeed whether - the exception is actually delivered will depend on the interrupt state - of the target thread. Raises Thread if the thread is no longer running, - so an exception handler should be used unless the thread is known to - be blocked. *) - val interrupt: thread -> unit - (*!Send an interrupt exception to every thread which is set to accept it. *) - val broadcastInterrupt: unit -> unit - (*!If this thread is handling interrupts synchronously, test to see - if it has been interrupted. If so it raises the - `Interrupt` exception. *) - val testInterrupt: unit -> unit - (*!Terminate a thread. This should be used as a last resort. Normally - a thread should be allowed to clean up and terminate by using the - interrupt call. Raises Thread if the thread is no longer running, - so an exception handler should be used unless the thread is known to - be blocked. *) - val kill: thread -> unit - - (*!Get and set thread-local store for the calling thread. The store is a - tagged associative memory which is initially empty for a new thread. - A thread can call setLocal to add or replace items in its store and - call getLocal to return values if they exist. The Universal structure - contains functions to make new tags as well as injection, projection and - test functions. *) - val getLocal: 'a Universal.tag -> 'a option - and setLocal: 'a Universal.tag * 'a -> unit - - (*!Change the specified attribute(s) for the calling thread. Unspecified - attributes remain unchanged. *) - val setAttributes: threadAttribute list -> unit - (*!Get the values of attributes. *) - val getAttributes: unit -> threadAttribute list - - (*!Return the number of processors that will be used to run threads - and the number of physical processors if that is available. *) - val numProcessors: unit -> int - and numPhysicalProcessors: unit -> int option - end - - structure Mutex: - sig - (*!A mutex provides simple mutual exclusion. A thread can lock - a mutex and until it unlocks it no other thread will be able to lock it. - Locking and unlocking are intended to be fast in the situation when - there is no other process attempting to lock the mutex. - These functions may not work correctly if an asynchronous interrupt - is delivered during the calls. A thread should use synchronous interrupt - when using these calls. *) - type mutex - (*!Make a new mutex *) - val mutex: unit -> mutex - (*!Lock a mutex. If the mutex is currently locked the thread is - blocked until it is unlocked. If a thread tries to lock a mutex that - it has previously locked the thread will deadlock. - N.B. `thread` is not an interruption point - (a point where synchronous - interrupts are delivered) even though a thread can be blocked indefinitely. *) - val lock: mutex -> unit - (*!Unlock a mutex and allow any waiting threads to run. The behaviour - if the mutex was not previously locked by the calling thread is undefined. *) - val unlock: mutex -> unit - (*!Attempt to lock the mutex. Returns true if the mutex was not - previously locked and has now been locked by the calling thread. Returns - false if the mutex was previously locked, including by the calling thread. *) - val trylock: mutex -> bool - - end - - structure ConditionVar: - sig - (*!Condition variables are used to provide communication - between threads. A condition variable is used in conjunction with a mutex - and usually a reference to establish and test changes in state. The normal - use is for one thread to lock a mutex, test the reference and then wait on - the condition variable, releasing the lock on the mutex while it does so. - Another thread may then lock the mutex, update the reference, unlock the - mutex, and signal the condition variable. This wakes up the first thread - and reacquires the lock allowing the thread to test the updated reference - with the lock held. - More complex communication mechanisms, such as blocking channels, can - be written in terms of condition variables. *) - type conditionVar - (*!Make a new condition variable. *) - val conditionVar: unit -> conditionVar - (*!Release the mutex and block until the condition variable is signalled. When - wait returns the mutex will have been re-acquired. - - If the thread is handling interrupts synchronously this function can be interrupted - using the `Thread.interrupt` function or, if the thread is set to - accept broadcast interrupts, `Thread.broadcastInterrupt`. The thread - will re-acquire the mutex before the exception is delivered. An exception - will only be delivered in this case if the interrupt is sent before the condition - variable is signalled. If the interrupt is sent after the condition variable - is signalled the function will return normally even if it has not yet re-acquired - the mutex. The interrupt state will be delivered on the next call to "wait", - `Thread.testInterrupt` or other blocking call. - - A thread should never call this function if it may receive an asynchronous - interrupt. It should always set its interrupt state to either - `InterruptSynch` - or `InterruptDefer` beforehand. - An asynchronous interrupt may leave the condition - variable and the mutex in an indeterminate state and could lead to deadlock. - - A condition variable should only be associated with one mutex at a time. - All the threads waiting on a condition variable should pass the same mutex - as argument.*) - val wait: conditionVar * Mutex.mutex -> unit - (*!As wait except that it blocks until either the condition - variable is signalled or the time (absolute) is reached. Either way - the mutex is reacquired so there may be a further delay if it is held - by another thread. *) - val waitUntil: conditionVar * Mutex.mutex * Time.time -> bool - (*!Wake up one thread if any are waiting on the condition variable. - If there are several threads waiting for the condition variable one will be - selected to run and will run as soon as it has re-acquired the lock.*) - val signal: conditionVar -> unit - (*!Wake up all threads waiting on the condition variable. *) - val broadcast: conditionVar -> unit - end - -end; - -structure Thread :> THREAD = -struct - exception Thread = RunCall.Thread - - structure Thread = - struct - open Thread (* Created in INITIALISE with thread type and self function. *) - - (* Equality is pointer equality. *) - val equal : thread*thread->bool = op = - - datatype threadAttribute = - EnableBroadcastInterrupt of bool - | InterruptState of interruptState - | MaximumMLStack of int option - - and interruptState = - InterruptDefer - | InterruptSynch - | InterruptAsynch - | InterruptAsynchOnce - - (* Convert attributes to bits and a mask. *) - fun attrsToWord (at: threadAttribute list): Word.word * Word.word = - let - (* Check that a particular attribute appears only once. - As well as accumulating the actual bits in the result we - also accumulate the mask of bits. If any of these - reappear we raise an exception. *) - fun checkRepeat(r, acc, set, mask) = - if Word.andb(set, mask) <> 0w0 - then raise Thread "The same attribute appears more than once in the list" - else convert(r, acc, Word.orb(set, mask)) - - and convert([], acc, set) = (acc, set) - | convert(EnableBroadcastInterrupt true :: r, acc, set) = - checkRepeat(r, Word.orb(acc, 0w1), set, 0w1) - | convert(EnableBroadcastInterrupt false :: r, acc, set) = - checkRepeat(r, acc (* No bit *), set, 0w1) - | convert(InterruptState s :: r, acc, set) = - checkRepeat(r, Word.orb(setIstateBits s, acc), set, 0w6) - | convert(MaximumMLStack _ :: r, acc, set) = - convert(r, acc, set) - in - convert(at, 0w0, 0w0) - end - - and setIstateBits InterruptDefer = 0w0 - | setIstateBits InterruptSynch = 0w2 - | setIstateBits InterruptAsynch = 0w4 - | setIstateBits InterruptAsynchOnce = 0w6 - - fun getIstateBits(w: Word.word): interruptState = - let - val ibits = Word.andb(w, 0w6) - in - if ibits = 0w0 - then InterruptDefer - else if ibits = 0w2 - then InterruptSynch - else if ibits = 0w4 - then InterruptAsynch - else InterruptAsynchOnce - end - - fun wordToAttrs w = - let - (* Enable broadcast - true if bottom bit is set. *) - val bcast = EnableBroadcastInterrupt(Word.andb(w, 0w1) = 0w1) - in - [bcast, InterruptState(getIstateBits w)] - end - - exception Interrupt = RunCall.Interrupt - - (* The thread id is opaque outside this structure but is actually a six - word mutable object. - Word 0: Index into thread table (used inside the RTS only) - Word 1: Flags: initialised by the RTS and set by this code - Word 2: Thread local store: read and set by this code. - Word 3: IntRequest: Set by the RTS if there is an interrupt pending - Word 4: Maximum ML stack size. Unlimited is stored here as zero - *) - val threadIdFlags = 0w1 - and threadIdThreadLocal = 0w2 - and threadIdIntRequest = 0w3 - and threadIdStackSize = 0w4 - - fun getLocal (t: 'a Universal.tag) : 'a option = - let - val root: Universal.universal ref list = - RunCall.loadWord(self(), threadIdThreadLocal) - - fun doFind [] = NONE - | doFind ((ref v)::r) = - if Universal.tagIs t v - then SOME(Universal.tagProject t v) - else doFind r - in - doFind root - end - - fun setLocal (t: 'a Universal.tag, newVal: 'a) : unit = - let - (* See if we already have this in the list. *) - val root: Universal.universal ref list = - RunCall.loadWord(self(), threadIdThreadLocal) - - fun doFind [] = - (* Not in the list - Add it. *) - RunCall.storeWord - (self(), threadIdThreadLocal, - ref (Universal.tagInject t newVal) :: root) - | doFind (v::r) = - if Universal.tagIs t (!v) - (* If it's in the list update it. *) - then v := Universal.tagInject t newVal - else doFind r - - in - doFind root - end - - local - val threadTestInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadTestInterrupt" - in - fun testInterrupt() = - (* If there is a pending request the word in the thread object - will be non-zero. *) - if RunCall.loadWord(self(), threadIdIntRequest) <> 0 - then threadTestInterrupt() - else () - end - - val exit: unit -> unit = RunCall.rtsCallFull0 "PolyThreadKillSelf" - and isActive: thread -> bool = RunCall.rtsCallFast1 "PolyThreadIsActive" - and broadcastInterrupt: unit -> unit = RunCall.rtsCallFull0 "PolyThreadBroadcastInterrupt" - - local - fun getAttrWord (me: thread) : Word.word = - RunCall.loadWord(me, threadIdFlags) - - fun getStackSizeAsInt (me: thread) : int = - RunCall.loadWord(me, threadIdStackSize) - - and getStackSize me : int option = - case getStackSizeAsInt me of - 0 => NONE - | s => SOME s - - fun newStackSize ([], default) = default - | newStackSize (MaximumMLStack NONE :: _, _) = 0 - | newStackSize (MaximumMLStack (SOME n) :: _, _) = - if n <= 0 then raise Thread "The stack size must be greater than zero" else n - | newStackSize (_ :: l, default) = newStackSize (l, default) - - val threadMaxStackSize: int -> unit = RunCall.rtsCallFull1 "PolyThreadMaxStackSize" - in - (* Set attributes. Only changes the values that are specified. The - others remain the same. *) - fun setAttributes (attrs: threadAttribute list) : unit = - let - val me = self() - val oldValues: Word.word = getAttrWord me - val (newValue, mask) = attrsToWord attrs - val stack = newStackSize(attrs, getStackSizeAsInt me) - in - RunCall.storeWord (self(), threadIdFlags, - Word.orb(newValue, Word.andb(Word.notb mask, oldValues))); - if stack = getStackSizeAsInt me - then () else threadMaxStackSize stack; - (* If we are now handling interrupts asynchronously check whether - we have a pending interrupt now. This will only be effective - if we were previously handling them synchronously or blocking - them. *) - if Word.andb(newValue, 0w4) = 0w4 - then testInterrupt() - else () - end - - fun getAttributes() : threadAttribute list = - let - val me = self() - in - MaximumMLStack (getStackSize me) :: wordToAttrs(getAttrWord me) - end - - (* These are used in the ConditionVar structure. They affect only the - interrupt handling bits. *) - fun getInterruptState(): interruptState = getIstateBits(getAttrWord(self())) - and setInterruptState(s: interruptState): unit = - RunCall.storeWord (self(), threadIdFlags, - Word.orb(setIstateBits s, Word.andb(Word.notb 0w6, getAttrWord(self())))) - - local - (* The default for a new thread is to ignore broadcasts and handle explicit - interrupts synchronously. *) - val (defaultAttrs, _) = - attrsToWord[EnableBroadcastInterrupt false, InterruptState InterruptSynch] - val threadForkFunction: - (unit->unit) * word * int -> thread = RunCall.rtsCallFull3 "PolyThreadForkThread" - in - fun fork(f:unit->unit, attrs: threadAttribute list): thread = - let - (* Any attributes specified explicitly override the defaults. *) - val (attrWord, mask) = attrsToWord attrs - val attrValue = Word.orb(attrWord, Word.andb(Word.notb mask, defaultAttrs)) - val stack = newStackSize(attrs, 0 (* Default is unlimited *)) - (* Run the function and exit whether it returns normally or raises an exception. *) - fun threadFunction () = (f() handle _ => ()) before exit() - in - threadForkFunction(threadFunction, attrValue, stack) - end - end - end - - local - (* Send an interrupt to a thread. If it returns false - the thread did not exist and this should raise an exception. *) - val threadSendInterrupt: thread -> bool = RunCall.rtsCallFast1 "PolyThreadInterruptThread" - in - fun interrupt(t: thread) = - if threadSendInterrupt t - then () - else raise Thread "Thread does not exist" - end - - local - val threadKillThread: thread -> bool = RunCall.rtsCallFast1 "PolyThreadKillThread" - in - fun kill(t: thread) = - if threadKillThread t - then () - else raise Thread "Thread does not exist" - end - - val numProcessors: unit -> int = RunCall.rtsCallFast0 "PolyThreadNumProcessors" - - local - val numberOfPhysical: unit -> int = - RunCall.rtsCallFast0 "PolyThreadNumPhysicalProcessors" - in - fun numPhysicalProcessors(): int option = - (* It is not always possible to get this information *) - case numberOfPhysical() of 0 => NONE | n => SOME n - end - end - - structure Mutex = - struct - type mutex = Word.word ref - val mutex = LibrarySupport.volatileWordRef (* Initially 0=unlocked. *) - open Thread (* atomicIncr, atomicDecr and atomicReset are set up by Initialise. *) - - val threadMutexBlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexBlock" - val threadMutexUnlock: mutex -> unit = RunCall.rtsCallFull1 "PolyThreadMutexUnlock" - - (* A mutex is implemented as a Word.word ref. It is initially set to 0 and locked - by atomically incrementing it. If it was previously unlocked the result will - by one but if it was already locked it will be some positive value. When it - is unlocked it is atomically decremented. If there was no contention the result - will again be 0 but if some other thread tried to lock it the result will be - one or positive. In that case the unlocking thread needs to call in to the - RTS to wake up the blocked thread. - - The cost of contention on the lock is very high. To try to avoid this we - first loop (spin) to see if we can get the lock without contention. *) - - val spin_cycle = 20000 - fun spin (m: mutex, c: int) = - if ! m = 0w0 then () - else if c = spin_cycle then () - else spin(m, c+1); - - fun lock (m: mutex): unit = - let - val () = spin(m, 0) - val newValue = atomicIncr m - in - if newValue = 0w1 - then () (* We've acquired the lock. *) - else (* It's locked. We return when we have the lock. *) - ( - threadMutexBlock m; - lock m (* Try again. *) - ) - end - - fun unlock (m: mutex): unit = - let - val newValue = atomicDecr m - in - if newValue = 0w0 - then () (* No contention. *) - else - (* Another thread has blocked and we have to release it. We can safely - set the value to 0 here to release the lock. If another thread - acquires it before we have woken up the other threads that's fine. - Equally, if another thread incremented the count and saw it was - still locked it will enter the RTS and try to acquire the lock - there. - It's probably better to reset it here rather than within the RTS - since it allows another thread to acquire the lock immediately - rather than after the rather long process of entering the RTS. - Resetting this needs to be atomic with respect to atomic increment - and decrement. That's not a problem on X86 so a simple assignment - is sufficient but in the interpreter at least it's necessary to - acquire a lock. *) - ( - atomicReset m; - threadMutexUnlock m - ) - end - - (* Try to lock the mutex. If it was previously unlocked then lock it and - return true otherwise return false. Because we don't block here there is - the possibility that the thread that has locked it could release the lock - shortly afterwards. The check for !m = 0w0 is an optimisation and nearly - all the time it avoids the call to atomicIncr setting m to a value > 1. - There is a small chance that another thread could lock the mutex between the - test for !m = 0w0 and the atomicIncr. In that case the atomicIncr would - return a value > 1 and the function that locked the mutex will have to - call into the RTS to reset it when it is unlocked. *) - fun trylock (m: mutex): bool = - if !m = 0w0 andalso atomicIncr m = 0w1 - then true (* We've acquired the lock. *) - else false (* The lock was taken. *) - end - - structure ConditionVar = - struct - open Thread - - (* A condition variable contains a lock and a list of suspended threads. *) - type conditionVar = { lock: Mutex.mutex, threads: thread list ref } - fun conditionVar(): conditionVar = - { lock = Mutex.mutex(), threads = LibrarySupport.volatileListRef() } - - local - val threadCondVarWait: Mutex.mutex -> unit = RunCall.rtsCallFull1 "PolyThreadCondVarWait" - and threadCondVarWaitUntil: Mutex.mutex * Time.time -> unit = RunCall.rtsCallFull2 "PolyThreadCondVarWaitUntil" - in - fun innerWait({lock, threads}: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = - let - val me = self() (* My thread id. *) - - fun waitAgain() = - let - fun doFind [] = false | doFind(h::t) = equal(h, me) orelse doFind t - - fun removeThis [] = raise Fail "Thread missing in list" - | removeThis (h::t) = if equal(h, me) then t else h :: removeThis t - - val () = - case t of - SOME time => threadCondVarWaitUntil(lock, time) - | NONE => threadCondVarWait lock - - val () = Mutex.lock lock (* Get the lock again. *) - - (* Are we still on the list? If so we haven't been explicitly woken - up. We've either timed out, been interrupted or simply returned - because the RTS needed to process some asynchronous results. *) - val stillThere = doFind(!threads) - open Time (* For >= *) - in - if not stillThere - then (* We're done. *) - ( - Mutex.unlock lock; - true - ) - else if (case t of NONE => false | SOME t => Time.now() >= t) - then (* We've timed out. *) - ( - threads := removeThis(! threads); - Mutex.unlock lock; - false - ) - else - ( - (* See if we've been interrupted. If so remove ourselves - and exit. *) - testInterrupt() - handle exn => (threads := removeThis(! threads); Mutex.unlock lock; raise exn); - (* Otherwise just keep waiting. *) - waitAgain() - ) - end - in - Mutex.lock lock; (* Lock the internal mutex. *) - Mutex.unlock m; (* Unlock the external mutex *) - threads := me :: !threads; (* Add ourselves to the list. *) - waitAgain() (* Wait and return the result when we're done. *) - end - - fun doWait(c: conditionVar, m: Mutex.mutex, t: Time.time option) : bool = - let - val originalIntstate = getInterruptState() - (* Set this to handle interrupts synchronously unless we're already - ignoring them. *) - val () = - if originalIntstate = InterruptDefer - then () - else setInterruptState InterruptSynch; - - (* Wait for the condition. If it raises an exception we still - need to reacquire the lock unless we were handling interrupts - asynchronously. *) - val result = - innerWait(c, m, t) handle exn => - ( - (* We had an exception. If we were handling exceptions synchronously - we reacquire the lock. If it was set to InterruptAsynchOnce this - counts as a single asynchronous exception and we restore the - state as InterruptSynch. *) - case originalIntstate of - InterruptDefer => (* Shouldn't happen? *) Mutex.lock m - | InterruptSynch => Mutex.lock m - | InterruptAsynch => setInterruptState InterruptAsynch - | InterruptAsynchOnce => setInterruptState InterruptSynch; - - raise exn (* Reraise the exception*) - ) - in - (* Restore the original interrupt state first. *) - setInterruptState originalIntstate; - (* Normal return. Reacquire the lock before returning. *) - Mutex.lock m; - result - end - - fun wait(c: conditionVar, m: Mutex.mutex) : unit = - (doWait(c, m, NONE); ()) - and waitUntil(c: conditionVar, m: Mutex.mutex, t: Time.time) : bool = - doWait(c, m, SOME t) - end - - local - (* This call wakes up the specified thread. If the thread has already been - interrupted and is not ignoring interrupts it returns false. Otherwise - it wakes up the thread and returns true. We have to use this because - we define that if a thread is interrupted before it is signalled then - it raises Interrupt. *) - val threadCondVarWake: thread -> bool = RunCall.rtsCallFast1 "PolyThreadCondVarWake" - - (* Wake a single thread if we can (signal). *) - fun wakeOne [] = [] - | wakeOne (thread::rest) = - if threadCondVarWake thread - then rest - else thread :: wakeOne rest - (* Wake all threads (broadcast). *) - fun wakeAll [] = [] (* Always returns the empty list. *) - | wakeAll (thread::rest) = (threadCondVarWake thread; wakeAll rest) - - fun signalOrBroadcast({lock, threads}: conditionVar, wakeThreads) : unit = - let - val originalState = getInterruptState() - in - (* Set this to handle interrupts synchronously unless we're already - ignoring them. We need to do this to avoid an asynchronous - interrupt which could leave the internal lock in an inconsistent state. *) - if originalState = InterruptDefer - then () - else setInterruptState InterruptSynch; - (* Get the condition var lock. *) - Mutex.lock lock; - threads := wakeThreads(! threads); - Mutex.unlock lock; - setInterruptState originalState; (* Restore original state. *) - (* Test if we were interrupted while we were handling - interrupts synchronously. *) - if originalState = InterruptAsynch orelse originalState = InterruptAsynchOnce - then testInterrupt() - else () - end - in - fun signal cv = signalOrBroadcast(cv, wakeOne) - and broadcast cv = signalOrBroadcast(cv, wakeAll) - end - end -end; - -local - fun prettyMutex _ _ (_: Thread.Mutex.mutex) = PolyML.PrettyString "?" - and prettyThread _ _ (_: Thread.Thread.thread) = PolyML.PrettyString "?" - and prettyCondVar _ _ (_: Thread.ConditionVar.conditionVar) = PolyML.PrettyString "?" -in - val () = PolyML.addPrettyPrinter prettyMutex - and () = PolyML.addPrettyPrinter prettyThread - and () = PolyML.addPrettyPrinter prettyCondVar -end; - - diff --git a/basis/Windows.581.sml b/basis/Windows.581.sml deleted file mode 100644 index bbf86708..00000000 --- a/basis/Windows.581.sml +++ /dev/null @@ -1,151 +0,0 @@ -(* - Title: Standard Basis Library: Windows signature and structure - Author: David Matthews - Copyright David Matthews 2000, 2005, 2012, 2018, 2019 - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - 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 -*) - -signature WINDOWS = -sig - structure Key : - sig - include BIT_FLAGS - val allAccess : flags - val createLink : flags - val createSubKey : flags - val enumerateSubKeys : flags - val execute : flags - val notify : flags - val queryValue : flags - val read : flags - val setValue : flags - val write : flags - end - structure Reg : - sig - eqtype hkey - val classesRoot : hkey - val currentUser : hkey - val localMachine : hkey - val users : hkey - val performanceData : hkey - val currentConfig : hkey - val dynData : hkey - - datatype create_result = - CREATED_NEW_KEY of hkey - | OPENED_EXISTING_KEY of hkey - val createKeyEx : hkey * string * Key.flags -> create_result - val openKeyEx : hkey * string * Key.flags -> hkey - val closeKey : hkey -> unit - val deleteKey : hkey * string -> unit - val deleteValue : hkey * string -> unit - val enumKeyEx : hkey * int -> string option - val enumValueEx : hkey * int -> string option - datatype value = - SZ of string - | DWORD of SysWord.word - | BINARY of Word8Vector.vector - | MULTI_SZ of string list - | EXPAND_SZ of string - val queryValueEx : hkey * string -> value option - val setValueEx : hkey * string * value -> unit - end - - structure Config: - sig - val platformWin32s : SysWord.word - val platformWin32Windows : SysWord.word - val platformWin32NT : SysWord.word - val platformWin32CE : SysWord.word - - val getVersionEx: unit -> - { majorVersion: SysWord.word, minorVersion: SysWord.word, - buildNumber: SysWord.word, platformId: SysWord.word, - csdVersion: string } - - val getWindowsDirectory: unit -> string - val getSystemDirectory: unit -> string - val getComputerName: unit -> string - val getUserName: unit -> string - end - - structure DDE : - sig - type info - val startDialog : string * string -> info - val executeString : info * string * int * Time.time -> unit - val stopDialog : info -> unit - end - - val getVolumeInformation : - string -> { - volumeName : string, - systemName : string, - serialNumber : SysWord.word, - maximumComponentLength : int - } - - val findExecutable : string -> string option - val launchApplication : string * string -> unit - val openDocument : string -> unit - val simpleExecute : string * string -> OS.Process.status - type ('a,'b) proc - val execute : string * string -> ('a, 'b) proc - val textInstreamOf : (TextIO.instream, 'a) proc -> TextIO.instream - val binInstreamOf : (BinIO.instream, 'a) proc -> BinIO.instream - val textOutstreamOf : ('a, TextIO.outstream) proc -> TextIO.outstream - val binOutstreamOf : ('a, BinIO.outstream) proc -> BinIO.outstream - val reap : ('a, 'b) proc -> OS.Process.status - - structure Status : - sig - type status = SysWord.word - val accessViolation : status - val arrayBoundsExceeded : status - val breakpoint : status - val controlCExit : status - val datatypeMisalignment : status - val floatDenormalOperand : status - val floatDivideByZero : status - val floatInexactResult : status - val floatInvalidOperation : status - val floatOverflow : status - val floatStackCheck : status - val floatUnderflow : status - val guardPageViolation : status - val integerDivideByZero : status - val integerOverflow : status - val illegalInstruction : status - val invalidDisposition : status - val invalidHandle : status - val inPageError : status - val noncontinuableException: status - val pending : status - val privilegedInstruction : status - val singleStep : status - val stackOverflow : status - val timeout : status - val userAPC : status - end - val fromStatus : OS.Process.status -> Status.status - val exit : Status.status -> 'a - -end; - -(* Provide an empty version for bootstrapping. It uses the FFI but that has changed. *) - -structure Windows = struct end;