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/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; diff --git a/libpolyml/globals.h b/libpolyml/globals.h index 63e0f8e1..5a0eb3a1 100644 --- a/libpolyml/globals.h +++ b/libpolyml/globals.h @@ -1,436 +1,428 @@ /* Title: Globals for the system. Author: Dave Matthews, Cambridge University Computer Laboratory Copyright David C. J. Matthews 2017-20 Copyright (c) 2000-7 Cambridge University Technical Services Limited 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 */ #ifndef _GLOBALS_H #define _GLOBALS_H /* Poly words, pointers and cells (objects). The garbage collector needs to be able to distinguish different uses of a memory word. We need to be able find which words are pointers to other objects and which are simple integers. The simple distinction is between integers, which are tagged by having the bottom bit set, and Addresses which are word aligned (bottom 2 bits zero on a 32 bit machine, bottom 3 bits on a 64 bit machine, bottom bit in 32-in-64). Addresses always point to the start of cells. The preceding word of a cell is the length word. This contains the length of the cell in words in the low-order 3 (7 in native 64-bits) bytes and a flag byte in the top byte. The flags give information about the type of the object. The length word is also used by the garbage collector and other object processors. */ #if HAVE_STDINT_H # include #endif #if HAVE_INTTYPES_H # ifndef __STDC_FORMAT_MACROS # define __STDC_FORMAT_MACROS # endif # include #elif (defined(_MSC_VER) && (_MSC_VER >= 1900)) // In VS 2015 and later we need to use # include #endif #ifdef HAVE_STDDEF_H # include #endif #define POLY_TAGSHIFT 1 #if (defined(_WIN32)) # include #endif #ifdef POLYML32IN64 typedef int32_t POLYSIGNED; typedef uint32_t POLYUNSIGNED; #define SIZEOF_POLYWORD 4 #else typedef intptr_t POLYSIGNED; typedef uintptr_t POLYUNSIGNED; #define SIZEOF_POLYWORD SIZEOF_VOIDP #endif // libpolyml uses printf-style I/O instead of C++ standard IOstreams, // so we need specifier to format POLYUNSIGNED/POLYSIGNED values. #ifdef POLYML32IN64 #if (defined(PRIu32)) # define POLYUFMT PRIu32 # define POLYSFMT PRId32 #elif (defined(_MSC_VER)) # define POLYUFMT "lu" # define POLYSFMT "ld" #else # define POLYUFMT "u" # define POLYSFMT "d" #endif #elif (defined(PRIuPTR)) # define POLYUFMT PRIuPTR # define POLYSFMT PRIdPTR #elif (defined(_MSC_VER) && (SIZEOF_POLYWORD == 8)) # define POLYUFMT "llu" # define POLYSFMT "lld" #else # define POLYUFMT "lu" // as before. Cross your fingers. # define POLYSFMT "ld" // idem. #endif // We can use the C99 %zu in most cases except MingW since it uses // the old msvcrt and that only supports C89. #if (defined(_WIN32) && (! defined(_MSC_VER) || _MSC_VER < 1800)) # if (SIZEOF_VOIDP == 8) # define PRI_SIZET PRIu64 # else # define PRI_SIZET PRIu32 # endif #else # define PRI_SIZET "zu" #endif typedef unsigned char byte; class PolyObject; typedef PolyObject *POLYOBJPTR; #ifdef POLYML32IN64 class PolyWord; extern PolyWord *globalHeapBase, *globalCodeBase; typedef uint32_t POLYOBJECTPTR; // This is an index into globalHeapBase // If a 64-bit value if in the range of the object pointers. inline bool IsHeapAddress(void *addr) { return (uintptr_t)addr <= 0xffffffff; } #else typedef POLYOBJPTR POLYOBJECTPTR; inline bool IsHeapAddress(void *) { return true; } #endif typedef byte *POLYCODEPTR; class PolyWord { public: // Initialise to TAGGED(0). This is very rarely used. PolyWord() { contents.unsignedInt = 1; } // Integers need to be tagged. static PolyWord TaggedInt(POLYSIGNED s) { return PolyWord((s << POLY_TAGSHIFT) | (POLYSIGNED)0x01); } static PolyWord TaggedUnsigned(POLYUNSIGNED u) { return PolyWord((u << POLY_TAGSHIFT) | 0x01); } static PolyWord FromStackAddr(PolyWord *sp) { return PolyWord(sp); } static PolyWord FromCodePtr(POLYCODEPTR p) { return PolyWord(p); } // Tests for the various cases. bool IsTagged(void) const { return (contents.unsignedInt & 1) != 0; } #ifndef POLYML32IN64 // In native 32-bit and 64-bit addresses are on word boundaries bool IsDataPtr(void) const { return (contents.unsignedInt & (sizeof(PolyWord) - 1)) == 0; } #else // In 32-in-64 addresses are anything that isn't tagged. bool IsDataPtr(void) const { return (contents.unsignedInt & 1) == 0; } #ifdef POLYML32IN64DEBUG static POLYOBJECTPTR AddressToObjectPtr(void *address); #else static POLYOBJECTPTR AddressToObjectPtr(void *address) { return (POLYOBJECTPTR)((PolyWord*)address - globalHeapBase); } #endif #endif // Extract the various cases. POLYSIGNED UnTagged(void) const { return contents.signedInt >> POLY_TAGSHIFT; } POLYUNSIGNED UnTaggedUnsigned(void) const { return contents.unsignedInt >> POLY_TAGSHIFT; } #ifdef POLYML32IN64 PolyWord(POLYOBJPTR p) { contents.objectPtr = AddressToObjectPtr(p); } PolyWord *AsStackAddr(PolyWord *base = globalHeapBase) const { return base + contents.objectPtr; } POLYOBJPTR AsObjPtr(PolyWord *base = globalHeapBase) const { return (POLYOBJPTR)AsStackAddr(base); } #else // An object pointer can become a word directly. PolyWord(POLYOBJPTR p) { contents.objectPtr = p; } POLYOBJPTR AsObjPtr(PolyWord *base = 0) const { return contents.objectPtr; } PolyWord *AsStackAddr(PolyWord *base=0) const { return (PolyWord *)contents.objectPtr; } #endif POLYCODEPTR AsCodePtr(void) const { return (POLYCODEPTR)AsObjPtr(); } void *AsAddress(void)const { return AsCodePtr(); } // There are a few cases where we need to store and extract untagged values static PolyWord FromUnsigned(POLYUNSIGNED u) { return PolyWord(u); } static PolyWord FromSigned(POLYSIGNED s) { return PolyWord(s); } POLYUNSIGNED AsUnsigned(void) const { return contents.unsignedInt; } POLYSIGNED AsSigned(void) const { return contents.signedInt; } protected: PolyWord(POLYSIGNED s) { contents.signedInt = s; } PolyWord(POLYUNSIGNED u) { contents.unsignedInt = u; } public: bool operator == (PolyWord b) const { return contents.unsignedInt == b.contents.unsignedInt; } bool operator != (PolyWord b) const { return contents.unsignedInt != b.contents.unsignedInt; } protected: #ifdef POLYML32IN64 PolyWord(PolyWord *sp) { contents.objectPtr = AddressToObjectPtr(sp); } PolyWord(POLYCODEPTR p) { contents.objectPtr = AddressToObjectPtr(p); } #else PolyWord(PolyWord *sp) { contents.objectPtr = (PolyObject*)sp; } PolyWord(POLYCODEPTR p) { contents.objectPtr = (PolyObject*)p; } #endif union { POLYSIGNED signedInt; // A tagged integer - lowest bit set POLYUNSIGNED unsignedInt; // A tagged integer - lowest bit set POLYOBJECTPTR objectPtr; // Object pointer - lowest bit clear. } contents; }; //typedef PolyWord POLYWORD; inline bool OBJ_IS_AN_INTEGER(const PolyWord & a) { return a.IsTagged(); } inline bool OBJ_IS_DATAPTR(const PolyWord & a) { return a.IsDataPtr(); } // The maximum tagged signed number is one less than 0x80 shifted into the top byte then shifted down // by the tag shift. #define MAXTAGGED (((POLYSIGNED)0x80 << (POLYSIGNED)(8*(sizeof(PolyWord)-1) -POLY_TAGSHIFT)) -1) inline PolyWord TAGGED(POLYSIGNED a) { return PolyWord::TaggedInt(a); } inline POLYSIGNED UNTAGGED(PolyWord a) { return a.UnTagged(); } inline POLYUNSIGNED UNTAGGED_UNSIGNED(PolyWord a) { return a.UnTaggedUnsigned(); } #define IS_INT(x) ((x).IsTagged()) /* length word flags */ #define OBJ_PRIVATE_FLAGS_SHIFT (8 * (sizeof(PolyWord) - 1)) #define _TOP_BYTE(x) ((POLYUNSIGNED)(x) << OBJ_PRIVATE_FLAGS_SHIFT) // Bottom two bits define the content format. // Zero bits mean ordinary word object containing addresses or tagged integers. #define F_BYTE_OBJ 0x01 /* byte object (contains no pointers) */ #define F_CODE_OBJ 0x02 /* code object (mixed bytes and words) */ #define F_CLOSURE_OBJ 0x03 /* closure (32-in-64 only). First word is code addr. */ #define F_GC_MARK 0x04 // Used during the GC marking phase #define F_NO_OVERWRITE 0x08 /* don't overwrite when loading - mutables only. */ // This bit is overloaded and has different meanings depending on what other bits are set. // For byte objects it is the sign bit for arbitrary precision ints. // For other data it indicates either that the object is a profile block or contains // information for allocation profiling. #define F_NEGATIVE_BIT 0x10 // Sign bit for arbitrary precision ints (byte segs only) #define F_PROFILE_BIT 0x10 // Object has a profile pointer (word segs only) #define F_WEAK_BIT 0x20 /* object contains weak references to option values. */ // The Weak bit is only used on mutables. The data sharing (sharedata.cpp) uses this with // immutables to indicate that the length field is being used to store the "depth". #define F_MUTABLE_BIT 0x40 /* object is mutable */ #define F_TOMBSTONE_BIT 0x80 // Object is a forwarding pointer #define F_PRIVATE_FLAGS_MASK 0xFF // Shifted bits #define _OBJ_BYTE_OBJ _TOP_BYTE(F_BYTE_OBJ) /* byte object (contains no pointers) */ #define _OBJ_CODE_OBJ _TOP_BYTE(F_CODE_OBJ) /* code object (mixed bytes and words) */ #define _OBJ_CLOSURE_OBJ _TOP_BYTE(F_CLOSURE_OBJ) // closure (32-in-64 only). First word is code addr. #define _OBJ_GC_MARK _TOP_BYTE(F_GC_MARK) // Mark bit #define _OBJ_NO_OVERWRITE _TOP_BYTE(F_NO_OVERWRITE) /* don't overwrite when loading - mutables only. */ #define _OBJ_NEGATIVE_BIT _TOP_BYTE(F_NEGATIVE_BIT) /* sign bit for arbitrary precision ints */ #define _OBJ_PROFILE_BIT _TOP_BYTE(F_PROFILE_BIT) /* sign bit for arbitrary precision ints */ #define _OBJ_WEAK_BIT _TOP_BYTE(F_WEAK_BIT) #define _OBJ_MUTABLE_BIT _TOP_BYTE(F_MUTABLE_BIT) /* object is mutable */ #define _OBJ_TOMBSTONE_BIT _TOP_BYTE(F_TOMBSTONE_BIT) // object is a tombstone. #define _OBJ_PRIVATE_FLAGS_MASK _TOP_BYTE(F_PRIVATE_FLAGS_MASK) #define _OBJ_PRIVATE_LENGTH_MASK ((-1) ^ _OBJ_PRIVATE_FLAGS_MASK) #define MAX_OBJECT_SIZE _OBJ_PRIVATE_LENGTH_MASK // inline bool OBJ_IS_LENGTH(POLYUNSIGNED L) { return ((L & _OBJ_TOMBSTONE_BIT) == 0); } /* these should only be applied to proper length words */ /* discards GC flag, mutable bit and weak bit. */ inline byte GetTypeBits(POLYUNSIGNED L) { return (byte)(L >> OBJ_PRIVATE_FLAGS_SHIFT) & 0x03; } inline POLYUNSIGNED OBJ_OBJECT_LENGTH(POLYUNSIGNED L) { return L & _OBJ_PRIVATE_LENGTH_MASK; } inline bool OBJ_IS_BYTE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_BYTE_OBJ); } inline bool OBJ_IS_CODE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CODE_OBJ); } inline bool OBJ_IS_CLOSURE_OBJECT(POLYUNSIGNED L) { return (GetTypeBits(L) == F_CLOSURE_OBJ); } inline bool OBJ_IS_NO_OVERWRITE(POLYUNSIGNED L) { return ((L & _OBJ_NO_OVERWRITE) != 0); } inline bool OBJ_IS_NEGATIVE(POLYUNSIGNED L) { return ((L & _OBJ_NEGATIVE_BIT) != 0); } inline bool OBJ_HAS_PROFILE(POLYUNSIGNED L) { return ((L & _OBJ_PROFILE_BIT) != 0); } inline bool OBJ_IS_MUTABLE_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_MUTABLE_BIT) != 0); } inline bool OBJ_IS_WEAKREF_OBJECT(POLYUNSIGNED L) { return ((L & _OBJ_WEAK_BIT) != 0); } /* Don't need to worry about whether shift is signed, because OBJ_PRIVATE_USER_FLAGS_MASK removes the sign bit. We don't want the GC bit (which should be 0) anyway. */ #define OBJ_PRIVATE_USER_FLAGS_MASK _TOP_BYTE(0x7F) #define OBJ_IS_WORD_OBJECT(L) (GetTypeBits(L) == 0) /* case 2 - forwarding pointer */ inline bool OBJ_IS_POINTER(POLYUNSIGNED L) { return (L & _OBJ_TOMBSTONE_BIT) != 0; } #ifdef POLYML32IN64 inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(globalHeapBase + ((L & ~_OBJ_TOMBSTONE_BIT) << 1)); } inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return PolyWord::AddressToObjectPtr(pt) >> 1 | _OBJ_TOMBSTONE_BIT; } #else inline PolyObject *OBJ_GET_POINTER(POLYUNSIGNED L) { return (PolyObject*)(( L & ~_OBJ_TOMBSTONE_BIT) <<2); } inline POLYUNSIGNED OBJ_SET_POINTER(PolyObject *pt) { return ((POLYUNSIGNED)pt >> 2) | _OBJ_TOMBSTONE_BIT; } #endif // An object i.e. a piece of allocated memory in the heap. In the simplest case this is a // tuple, a list cons cell, a string or a ref. Every object has a length word in the word before // where its address points. The top byte of this contains flags. class PolyObject { public: byte *AsBytePtr(void)const { return (byte*)this; } PolyWord *AsWordPtr(void)const { return (PolyWord*)this; } POLYUNSIGNED LengthWord(void)const { return ((PolyWord*)this)[-1].AsUnsigned(); } POLYUNSIGNED Length(void)const { return OBJ_OBJECT_LENGTH(LengthWord()); } // Get and set a word PolyWord Get(POLYUNSIGNED i) const { return ((PolyWord*)this)[i]; } void Set(POLYUNSIGNED i, PolyWord v) { ((PolyWord*)this)[i] = v; } PolyWord *Offset(POLYUNSIGNED i) const { return ((PolyWord*)this)+i; } // Create a length word from a length and the flags in the top byte. void SetLengthWord(POLYUNSIGNED l, byte f) { ((POLYUNSIGNED*)this)[-1] = l | ((POLYUNSIGNED)f << OBJ_PRIVATE_FLAGS_SHIFT); } void SetLengthWord(POLYUNSIGNED l) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(l); } bool IsByteObject(void) const { return OBJ_IS_BYTE_OBJECT(LengthWord()); } bool IsCodeObject(void) const { return OBJ_IS_CODE_OBJECT(LengthWord()); } bool IsClosureObject(void) const { return OBJ_IS_CLOSURE_OBJECT(LengthWord()); } bool IsWordObject(void) const { return OBJ_IS_WORD_OBJECT(LengthWord()); } bool IsMutable(void) const { return OBJ_IS_MUTABLE_OBJECT(LengthWord()); } bool IsWeakRefObject(void) const { return OBJ_IS_WEAKREF_OBJECT(LengthWord()); } bool IsNoOverwriteObject(void) const { return OBJ_IS_NO_OVERWRITE(LengthWord()); } bool ContainsForwardingPtr(void) const { return OBJ_IS_POINTER(LengthWord()); } PolyObject *GetForwardingPtr(void) const { return OBJ_GET_POINTER(LengthWord()); } void SetForwardingPtr(PolyObject *newp) { ((PolyWord*)this)[-1] = PolyWord::FromUnsigned(OBJ_SET_POINTER(newp)); } bool ContainsNormalLengthWord(void) const { return OBJ_IS_LENGTH(LengthWord()); } // Find the start of the constant section for a piece of code. // The first of these is really only needed because we may have objects whose length // words have been overwritten. void GetConstSegmentForCode(POLYUNSIGNED obj_length, PolyWord * &cp, POLYUNSIGNED &count) const { PolyWord *last_word = Offset(obj_length - 1); // Last word in the code - if (last_word->AsSigned() < 0) - { - cp = last_word + 1 + last_word->AsSigned() / sizeof(PolyWord); - count = cp[-1].AsUnsigned(); - } - else - { - count = last_word->AsUnsigned(); // This is the number of consts - cp = last_word - count; - } + cp = last_word + 1 + last_word->AsSigned() / sizeof(PolyWord); + count = cp[-1].AsUnsigned(); } void GetConstSegmentForCode(PolyWord * &cp, POLYUNSIGNED &count) const { GetConstSegmentForCode(Length(), cp, count); } PolyWord *ConstPtrForCode(void) const { PolyWord *cp; POLYUNSIGNED count; GetConstSegmentForCode(cp, count); return cp; } // Follow a chain of forwarding pointers PolyObject *FollowForwardingChain(void) { if (ContainsForwardingPtr()) return GetForwardingPtr()->FollowForwardingChain(); else return this; } }; // Stacks are native-words size even in 32-in-64. union stackItem { stackItem(PolyWord v) { argValue = v.AsUnsigned(); } stackItem() { argValue = TAGGED(0).AsUnsigned(); } // These return the low order word. PolyWord w()const { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } operator PolyWord () { return PolyWord::FromUnsigned((POLYUNSIGNED)argValue); } POLYCODEPTR codeAddr; // Return addresses stackItem* stackAddr; // Stack addresses uintptr_t argValue; // Treat an address as an int }; /* There was a problem with version 2.95 on Sparc/Solaris at least. The PolyObject class has no members so classes derived from it e.g. ML_Cons_Cell should begin at the beginning of the object. Later versions of GCC get this right. */ #if defined(__GNUC__) && (__GNUC__ <= 2) #error Poly/ML requires GCC version 3 or newer #endif inline POLYUNSIGNED GetLengthWord(PolyWord p) { return p.AsObjPtr()->LengthWord(); } // Get the length of an object. inline POLYUNSIGNED OBJECT_LENGTH(PolyWord p) { return OBJ_OBJECT_LENGTH(GetLengthWord(p)); } // A list cell. This can be passed to or returned from certain RTS functions. class ML_Cons_Cell: public PolyObject { public: PolyWord h; PolyWord t; #define ListNull (TAGGED(0)) static bool IsNull(PolyWord p) { return p == ListNull; } }; /* An exception packet. This contains an identifier (either a tagged integer for RTS exceptions or the address of a mutable for those created within ML), a string name for printing and an exception argument value. */ class PolyException: public PolyObject { public: PolyWord ex_id; /* Exc identifier */ PolyWord ex_name;/* Exc name */ PolyWord arg; /* Exc arguments */ PolyWord ex_location; // Location of "raise". Always zero for RTS exceptions. }; typedef PolyException poly_exn; /* Macro to round a number of bytes up to a number of words. */ #define WORDS(s) ((s+sizeof(PolyWord)-1)/sizeof(PolyWord)) /********************************************************************** * * Representation of option type. * **********************************************************************/ #define NONE_VALUE (TAGGED(0)) /* SOME x is represented by a single word cell containing x. */ #if (defined(_WIN32)) /* Windows doesn't include 0x in %p format. */ #define ZERO_X "0x" #else #define ZERO_X "" #endif #endif diff --git a/libpolyml/pexport.cpp b/libpolyml/pexport.cpp index c45db4d6..cf7ba04b 100644 --- a/libpolyml/pexport.cpp +++ b/libpolyml/pexport.cpp @@ -1,913 +1,903 @@ /* Title: Export and import memory in a portable format Author: David C. J. Matthews. Copyright (c) 2006-7, 2015-8, 2020 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 H 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 */ #ifdef HAVE_CONFIG_H #include "config.h" #elif defined(_WIN32) #include "winconfig.h" #else #error "No configuration file" #endif #ifdef HAVE_STDIO_H #include #endif #ifdef HAVE_ERRNO_H #include #endif #ifdef HAVE_ASSERT_H #include #define ASSERT(x) assert(x) #else #define ASSERT(x) #endif #include "globals.h" #include "pexport.h" #include "machine_dep.h" #include "scanaddrs.h" #include "run_time.h" #include "../polyexports.h" #include "version.h" #include "sys.h" #include "polystring.h" #include "memmgr.h" #include "rtsentry.h" #include "mpoly.h" // For polyStderr /* This file contains the code both to export the file and to import it in a new session. */ PExport::PExport() { } PExport::~PExport() { } // Get the index corresponding to an address. size_t PExport::getIndex(PolyObject *p) { // Binary chop to find the index from the address. size_t lower = 0, upper = pMap.size(); while (1) { ASSERT(lower < upper); size_t middle = (lower+upper)/2; ASSERT(middle < pMap.size()); if (p < pMap[middle]) { // Use lower to middle upper = middle; } else if (p > pMap[middle]) { // Use middle+1 to upper lower = middle+1; } else // Found it return middle; } } /* Get the index corresponding to an address. */ void PExport::printAddress(void *p) { fprintf(exportFile, "@%" PRI_SIZET "", getIndex((PolyObject*)p)); } void PExport::printValue(PolyWord q) { if (IS_INT(q) || q == PolyWord::FromUnsigned(0)) fprintf(exportFile, "%" POLYSFMT, UNTAGGED(q)); else printAddress(q.AsAddress()); } void PExport::printObject(PolyObject *p) { POLYUNSIGNED length = p->Length(); POLYUNSIGNED i; size_t myIndex = getIndex(p); fprintf(exportFile, "%" PRI_SIZET ":", myIndex); if (p->IsMutable()) putc('M', exportFile); if (OBJ_IS_NEGATIVE(p->LengthWord())) putc('N', exportFile); if (OBJ_IS_WEAKREF_OBJECT(p->LengthWord())) putc('W', exportFile); if (OBJ_IS_NO_OVERWRITE(p->LengthWord())) putc('V', exportFile); if (p->IsByteObject()) { if (p->IsMutable() && p->IsWeakRefObject() && p->Length() >= sizeof(uintptr_t) / sizeof(PolyWord)) { // This is either an entry point or a weak ref used in the FFI. // Clear the first word if (p->Length() == sizeof(uintptr_t)/sizeof(PolyWord)) putc('K', exportFile); // Weak ref else if (p->Length() > sizeof(uintptr_t) / sizeof(PolyWord)) { // Entry point - C null-terminated string. putc('E', exportFile); const char* name = (char*)p + sizeof(uintptr_t); fprintf(exportFile, "%" PRI_SIZET "|%s", strlen(name), name); *(uintptr_t*)p = 0; // Entry point } } else { /* May be a string, a long format arbitrary precision number or a real number. */ PolyStringObject* ps = (PolyStringObject*)p; /* This is not infallible but it seems to be good enough to detect the strings. */ POLYUNSIGNED bytes = length * sizeof(PolyWord); if (length >= 2 && ps->length <= bytes - sizeof(POLYUNSIGNED) && ps->length > bytes - 2 * sizeof(POLYUNSIGNED)) { /* Looks like a string. */ fprintf(exportFile, "S%" POLYUFMT "|", ps->length); for (unsigned i = 0; i < ps->length; i++) { char ch = ps->chars[i]; fprintf(exportFile, "%02x", ch & 0xff); } } else { /* Not a string. May be an arbitrary precision integer. If the source and destination word lengths differ we could find that some long-format arbitrary precision numbers could be represented in the tagged short form or vice-versa. The former case might give rise to errors because when comparing two arbitrary precision numbers for equality we assume that they are not equal if they have different representation. The latter case could be a problem because we wouldn't know whether to convert the tagged form to long form, which would be correct if the value has type "int" or to truncate it which would be correct for "word". It could also be a real number but that doesn't matter if we recompile everything on the new machine. */ byte* u = (byte*)p; putc('B', exportFile); fprintf(exportFile, "%" PRI_SIZET "|", length * sizeof(PolyWord)); for (unsigned i = 0; i < (unsigned)(length * sizeof(PolyWord)); i++) { fprintf(exportFile, "%02x", u[i]); } } } } else if (p->IsCodeObject()) { POLYUNSIGNED constCount; PolyWord *cp; ASSERT(! p->IsMutable() ); /* Work out the number of bytes in the code and the number of constants. */ p->GetConstSegmentForCode(cp, constCount); /* The byte count is the length of the segment minus the number of constants minus one for the constant count. It includes the marker word, byte count, profile count and, on the X86/64 at least, any non-address constants. These are actually word values. */ PolyWord* last_word = p->Offset(length - 1); - POLYUNSIGNED byteCount = (length - constCount - 1) * sizeof(PolyWord); - if (last_word->AsSigned() < 0) - { - byteCount -= sizeof(PolyWord); - fprintf(exportFile, "F%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); - } - else - { - // Old format - fprintf(exportFile, "D%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); - } + POLYUNSIGNED byteCount = (length - constCount - 2) * sizeof(PolyWord); + fprintf(exportFile, "F%" POLYUFMT ",%" POLYUFMT "|", constCount, byteCount); // First the code. byte *u = (byte*)p; for (POLYUNSIGNED i = 0; i < byteCount; i++) fprintf(exportFile, "%02x", u[i]); putc('|', exportFile); // Now the constants. for (POLYUNSIGNED i = 0; i < constCount; i++) { printValue(cp[i]); if (i < constCount-1) putc(',', exportFile); } putc('|', exportFile); // Finally any constants in the code object. machineDependent->ScanConstantsWithinCode(p, this); } else // Ordinary objects, essentially tuples, or closures. { if (p->IsClosureObject()) { POLYUNSIGNED nItems = length - sizeof(PolyObject*) / sizeof(PolyWord) + 1; fprintf(exportFile, "C%" POLYUFMT "|", nItems); // Number of items } else fprintf(exportFile, "O%" POLYUFMT "|", length); if (p->IsClosureObject()) { // The first word is always a code address. printAddress(*(PolyObject**)p); i = sizeof(PolyObject*)/sizeof(PolyWord); if (i < length) putc(',', exportFile); } else i = 0; while (i < length) { printValue(p->Get(i)); if (i < length-1) putc(',', exportFile); i++; } } fprintf(exportFile, "\n"); } /* This is called for each constant within the code. Print a relocation entry for the word and return a value that means that the offset is saved in original word. */ void PExport::ScanConstant(PolyObject *base, byte *addr, ScanRelocationKind code) { PolyObject *p = GetConstantValue(addr, code); if (p == 0) return; // Don't put in tagged constants // Put in the byte offset and the relocation type code. POLYUNSIGNED offset = (POLYUNSIGNED)(addr - (byte*)base); ASSERT (offset < base->Length() * sizeof(POLYUNSIGNED)); fprintf(exportFile, "%" POLYUFMT ",%d,", (POLYUNSIGNED)(addr - (byte*)base), code); printAddress(p); // The value to plug in. fprintf(exportFile, " "); } void PExport::exportStore(void) { // We want the entries in pMap to be in ascending // order of address to make searching easy so we need to process the areas // in order of increasing address, which may not be the order in memTable. std::vector indexOrder; indexOrder.reserve(memTableEntries); for (size_t i = 0; i < memTableEntries; i++) { std::vector::iterator it; for (it = indexOrder.begin(); it != indexOrder.end(); it++) { if (memTable[*it].mtOriginalAddr >= memTable[i].mtOriginalAddr) break; } indexOrder.insert(it, i); } // Process the area in order of ascending address. for (std::vector::iterator i = indexOrder.begin(); i != indexOrder.end(); i++) { size_t index = *i; char *start = (char*)memTable[index].mtOriginalAddr; char *end = start + memTable[index].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); pMap.push_back(obj); p += length; } } /* Start writing the information. */ fprintf(exportFile, "Objects\t%" PRI_SIZET "\n", pMap.size()); char arch = '?'; switch (machineDependent->MachineArchitecture()) { case MA_Interpreted: arch = 'I'; break; case MA_I386: case MA_X86_64: case MA_X86_64_32: arch = 'X'; break; } fprintf(exportFile, "Root\t%" PRI_SIZET " %c %u\n", getIndex(rootFunction), arch, (unsigned)sizeof(PolyWord)); // Generate each of the areas. for (size_t i = 0; i < memTableEntries; i++) { char *start = (char*)memTable[i].mtOriginalAddr; char *end = start + memTable[i].mtLength; for (PolyWord *p = (PolyWord*)start; p < (PolyWord*)end; ) { p++; PolyObject *obj = (PolyObject*)p; POLYUNSIGNED length = obj->Length(); #ifdef POLYML32IN64 // We may have filler cells to get the alignment right. // We mustn't try to print them. if (((uintptr_t)obj & 4) != 0 && length == 0) continue; #endif printObject(obj); p += length; } } fclose(exportFile); exportFile = NULL; } /* Import a portable export file and load it into memory. Creates "permanent" address entries in the global memory table. */ class SpaceAlloc { public: SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def); PolyObject *NewObj(POLYUNSIGNED objWords); size_t defaultSize; PermanentMemSpace *memSpace; size_t used; unsigned permissions; unsigned *spaceIndexCtr; }; SpaceAlloc::SpaceAlloc(unsigned *indexCtr, unsigned perms, POLYUNSIGNED def) { permissions = perms; defaultSize = def; memSpace = 0; used = 0; spaceIndexCtr = indexCtr; } // Allocate a new object. May create a new space and add the old one to the permanent // memory table if this is exhausted. #ifndef POLYML32IN64 PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { if (memSpace == 0 || memSpace->spaceSize() - used <= objWords) { // Need some more space. size_t size = defaultSize; if (size <= objWords) size = objWords+1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return 0; } used = 0; } ASSERT(memSpace->spaceSize() - used > objWords); PolyObject *newObj = (PolyObject*)(memSpace->bottom + used+1); used += objWords+1; return newObj; } #else // With 32in64 we need to allocate on 8-byte boundaries. PolyObject *SpaceAlloc::NewObj(POLYUNSIGNED objWords) { size_t rounded = objWords; if ((objWords & 1) == 0) rounded++; if (memSpace == 0 || memSpace->spaceSize() - used <= rounded) { // Need some more space. size_t size = defaultSize; if (size <= rounded) size = rounded + 1; memSpace = gMem.AllocateNewPermanentSpace(size * sizeof(PolyWord), permissions, *spaceIndexCtr); (*spaceIndexCtr)++; // The memory is writable until CompletePermanentSpaceAllocation is called if (memSpace == 0) { fprintf(stderr, "Unable to allocate memory\n"); return 0; } memSpace->writeAble(memSpace->bottom)[0] = PolyWord::FromUnsigned(0); used = 1; } PolyObject *newObj = (PolyObject*)(memSpace->bottom + used + 1); if (rounded != objWords) memSpace->writeAble(newObj)->Set(objWords, PolyWord::FromUnsigned(0)); used += rounded + 1; ASSERT(((uintptr_t)newObj & 0x7) == 0); return newObj; } #endif class PImport { public: PImport(); ~PImport(); bool DoImport(void); FILE *f; PolyObject *Root(void) { return objMap[nRoot]; } private: bool ReadValue(PolyObject *p, POLYUNSIGNED i); bool GetValue(PolyWord *result); POLYUNSIGNED nObjects, nRoot; PolyObject **objMap; unsigned spaceIndex; SpaceAlloc mutSpace, immutSpace, codeSpace; }; PImport::PImport(): mutSpace(&spaceIndex, MTF_WRITEABLE, 1024*1024), immutSpace(&spaceIndex, 0, 1024*1024), codeSpace(&spaceIndex, MTF_EXECUTABLE, 1024 * 1024) { f = NULL; objMap = 0; spaceIndex = 1; } PImport::~PImport() { if (f) fclose(f); free(objMap); } bool PImport::GetValue(PolyWord *result) { int ch = getc(f); if (ch == '@') { /* Address of an object. */ POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *result = objMap[obj]; } else if ((ch >= '0' && ch <= '9') || ch == '-') { /* Tagged integer. */ POLYSIGNED j; ungetc(ch, f); fscanf(f, "%" POLYSFMT, &j); /* The assertion may be false if we are porting to a machine with a shorter tagged representation. */ ASSERT(j >= -MAXTAGGED-1 && j <= MAXTAGGED); *result = TAGGED(j); } else { fprintf(polyStderr, "Unexpected character in stream"); return false; } return true; } /* Read a value and store it at the specified word. */ bool PImport::ReadValue(PolyObject *p, POLYUNSIGNED i) { PolyWord result = TAGGED(0); if (GetValue(&result)) { p->Set(i, result); return true; } else return false; } bool PImport::DoImport() { int ch; POLYUNSIGNED objNo; ASSERT(gMem.pSpaces.size() == 0); ASSERT(gMem.eSpaces.size() == 0); ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nObjects); /* Create a mapping table. */ objMap = (PolyObject**)calloc(nObjects, sizeof(PolyObject*)); if (objMap == 0) { fprintf(polyStderr, "Unable to allocate memory\n"); return false; } do { ch = getc(f); } while (ch == '\n'); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\t') ; fscanf(f, "%" POLYUFMT, &nRoot); do { ch = getc(f); } while (ch == ' ' || ch == '\t'); // Older versions did not have the architecture and word length. if (ch != '\r' && ch != '\n') { unsigned wordLength; while (ch == ' ' || ch == '\t') ch = getc(f); char arch = ch; ch = getc(f); fscanf(f, "%u", &wordLength); // If we're booting a native code version from interpreted // code we have to interpret. machineDependent->SetBootArchitecture(arch, wordLength); } /* Now the objects themselves. */ while (1) { unsigned objBits = 0; POLYUNSIGNED nWords, nBytes; do { ch = getc(f); } while (ch == '\r' || ch == '\n'); if (ch == EOF) break; ungetc(ch, f); fscanf(f, "%" POLYUFMT, &objNo); ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); /* Modifiers, MNVW. */ do { ch = getc(f); if (ch == 'M') objBits |= F_MUTABLE_BIT; else if (ch == 'N') objBits |= F_NEGATIVE_BIT; if (ch == 'V') objBits |= F_NO_OVERWRITE; if (ch == 'W') objBits |= F_WEAK_BIT; } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ fscanf(f, "%" POLYUFMT, &nWords); break; case 'B': /* Byte segment. */ objBits |= F_BYTE_OBJ; fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'S': /* String. */ objBits |= F_BYTE_OBJ; /* The length is the number of characters. */ fscanf(f, "%" POLYUFMT, &nBytes); /* Round up to appropriate number of words. Need to add one PolyWord for the length PolyWord. */ nWords = (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord) + 1; break; - case 'D': // Code segment. case 'F': objBits |= F_CODE_OBJ; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); - nWords += ch == 'F' ? 2 : 1; // Add one or two words for no of consts + offset. + nWords += 2; // Add two words for no of consts + offset. /* Add in the size of the code itself. */ nWords += (nBytes + sizeof(PolyWord) -1) / sizeof(PolyWord); break; case 'C': // Closure objBits |= F_CLOSURE_OBJ; fscanf(f, "%" POLYUFMT, &nWords); // This is the number of items. nWords += sizeof(PolyObject*) / sizeof(PolyWord) - 1; break; case 'L': // Legacy closure objBits |= F_CLOSURE_OBJ; fscanf(f, "%" POLYUFMT, &nWords); // This was the number of words. break; case 'K': // Single weak reference nWords = sizeof(uintptr_t)/sizeof(PolyWord); objBits |= F_BYTE_OBJ; break; case 'E': // Entry point - address followed by string objBits |= F_BYTE_OBJ; // The length is the length of the string but it must be null-terminated fscanf(f, "%" POLYUFMT, &nBytes); // Add one uintptr_t plus one plus padding to an integral number of words. nWords = (nBytes + sizeof(uintptr_t) + sizeof(PolyWord)) / sizeof(PolyWord); break; default: fprintf(polyStderr, "Invalid object type\n"); return false; } SpaceAlloc* alloc; if (objBits & F_MUTABLE_BIT) alloc = &mutSpace; else if ((objBits & 3) == F_CODE_OBJ) alloc = &codeSpace; else alloc = &immutSpace; PolyObject* p = alloc->NewObj(nWords); if (p == 0) return false; objMap[objNo] = p; /* Put in length PolyWord and flag bits. */ alloc->memSpace->writeAble(p)->SetLengthWord(nWords, objBits); /* Skip the object contents. */ while (getc(f) != '\n') ; } /* Second pass - fill in the contents. */ fseek(f, 0, SEEK_SET); /* Skip the information at the start. */ ch = getc(f); ASSERT(ch == 'O'); /* Number of objects. */ while (getc(f) != '\n'); ch = getc(f); ASSERT(ch == 'R'); /* Root object number. */ while (getc(f) != '\n') ; while (1) { if (feof(f)) break; fscanf(f, "%" POLYUFMT, &objNo); if (feof(f)) break; ch = getc(f); ASSERT(ch == ':'); ASSERT(objNo < nObjects); PolyObject * p = objMap[objNo]; /* Modifiers, M or N. */ do { ch = getc(f); } while (ch == 'M' || ch == 'N' || ch == 'V' || ch == 'W'); /* Object type. */ switch (ch) { case 'O': /* Simple object. */ case 'C': // Closure case 'L': // Legacy closure { POLYUNSIGNED nWords; bool isClosure = ch == 'C' || ch == 'L'; fscanf(f, "%" POLYUFMT, &nWords); if (ch == 'C') nWords += sizeof(PolyObject*) / sizeof(PolyWord) - 1; ch = getc(f); ASSERT(ch == '|'); ASSERT(nWords == p->Length()); POLYUNSIGNED i = 0; if (isClosure) { int ch = getc(f); // This should be an address if (ch != '@') return false; POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); *(PolyObject**)p = objMap[obj]; ch = getc(f); i = sizeof(PolyObject*) / sizeof(PolyWord); } while (i < nWords) { if (!ReadValue(p, i)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords - 1) || (ch == '\n' && i == nWords - 1)); i++; } break; } case 'B': /* Byte segment. */ { byte *u = (byte*)p; POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } ch = getc(f); ASSERT(ch == '\n'); // Legacy: If this is an entry point object set its value. if (p->IsMutable() && p->IsWeakRefObject() && p->Length() > sizeof(uintptr_t)/sizeof(PolyWord)) { bool loadEntryPt = setEntryPoint(p); ASSERT(loadEntryPt); } break; } case 'S': /* String. */ { PolyStringObject * ps = (PolyStringObject *)p; /* The length is the number of characters. */ POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); ps->length = nBytes; for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); ps->chars[i] = n; } ch = getc(f); ASSERT(ch == '\n'); break; } case 'D': case 'F': { bool newForm = ch == 'F'; POLYUNSIGNED length = p->Length(); POLYUNSIGNED nWords, nBytes; MemSpace* space = gMem.SpaceForObjectAddress(p); PolyObject *wr = space->writeAble(p); byte* u = (byte*)wr; /* Read the number of bytes of code and the number of words for constants. */ fscanf(f, "%" POLYUFMT ",%" POLYUFMT, &nWords, &nBytes); /* Read the code. */ ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { int n; fscanf(f, "%02x", &n); u[i] = n; } ch = getc(f); ASSERT(ch == '|'); if (newForm) { wr->Set(length - nWords - 2, PolyWord::FromUnsigned(nWords)); wr->Set(length - 1, PolyWord::FromSigned((0-nWords-1)*sizeof(PolyWord))); } else wr->Set(length-1, PolyWord::FromUnsigned(nWords)); /* Read in the constants. */ for (POLYUNSIGNED i = 0; i < nWords; i++) { if (! ReadValue(wr, i+length-nWords-1)) return false; ch = getc(f); ASSERT((ch == ',' && i < nWords-1) || ((ch == '\n' || ch == '|') && i == nWords-1)); } // Read in any constants in the code. if (ch == '|') { ch = getc(f); while (ch != '\n') { ungetc(ch, f); POLYUNSIGNED offset; int code; fscanf(f, "%" POLYUFMT ",%d", &offset, &code); ch = getc(f); ASSERT(ch == ','); // This should be an address. ch = getc(f); if (ch == '@') { POLYUNSIGNED obj; fscanf(f, "%" POLYUFMT, &obj); ASSERT(obj < nObjects); PolyObject *addr = objMap[obj]; byte *toPatch = (byte*)p + offset; // Pass the execute address here. ScanAddress::SetConstantValue(toPatch, addr, (ScanRelocationKind)code); } else { // Previously we also included tagged constants but they are // already in the code. ungetc(ch, f); PolyWord w; if (!GetValue(&w)) return false; } do ch = getc(f); while (ch == ' '); } } // Clear the mutable bit wr->SetLengthWord(p->Length(), F_CODE_OBJ); break; } case 'K': // Weak reference - must be zeroed *(uintptr_t*)p = 0; break; case 'E': // Entry point - address followed by string { // The length is the number of characters. *(uintptr_t*)p = 0; char* b = (char*)p + sizeof(uintptr_t); POLYUNSIGNED nBytes; fscanf(f, "%" POLYUFMT, &nBytes); ch = getc(f); ASSERT(ch == '|'); for (POLYUNSIGNED i = 0; i < nBytes; i++) { ch = getc(f); *b++ = ch; } *b = 0; ch = getc(f); ASSERT(ch == '\n'); bool loadEntryPt = setEntryPoint(p); ASSERT(loadEntryPt); break; } default: fprintf(polyStderr, "Invalid object type\n"); return false; } } // Now remove write access from immutable spaces. for (std::vector::iterator i = gMem.pSpaces.begin(); i < gMem.pSpaces.end(); i++) gMem.CompletePermanentSpaceAllocation(*i); return true; } // Import a file in the portable format and return a pointer to the root object. PolyObject *ImportPortable(const TCHAR *fileName) { PImport pImport; #if (defined(_WIN32) && defined(UNICODE)) pImport.f = _wfopen(fileName, L"r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %S\n", fileName); return 0; } #else pImport.f = fopen(fileName, "r"); if (pImport.f == 0) { fprintf(polyStderr, "Unable to open file: %s\n", fileName); return 0; } #endif if (pImport.DoImport()) return pImport.Root(); else return 0; }