├── .gitignore ├── LICENSE ├── README.md ├── libsrc ├── CodeTemplates │ ├── README.md │ └── code-template.sml ├── ConstArith │ ├── README.md │ ├── bitwise-const-arith-sig.sml │ ├── bitwise-const-arith.sml │ ├── check-bitwise-arith-fn.sml │ ├── check-signed-arith-fn.sml │ ├── check-unsigned-arith-fn.sml │ ├── const-arith-glue-fn.sml │ ├── const-arith-sig.sml │ ├── signed-const-arith-sig.sml │ ├── signed-trapping-arith.sml │ ├── signed-wrapping-arith.sml │ ├── sources.cm │ ├── test.cm │ ├── test.sml │ ├── unsigned-const-arith-sig.sml │ ├── unsigned-trapping-arith.sml │ └── unsigned-wrapping-arith.sml ├── Errors │ ├── README.md │ └── error.sml ├── Floats │ ├── README.md │ ├── float-constants.sml │ ├── float-lit.sml │ ├── float-to-bits-fn.sml │ ├── float-to-bits-sig.sml │ ├── float-to-llvm-ir.sml │ ├── float16-to-llvm.sml │ ├── float32-to-llvm.sml │ ├── sources.cm │ ├── test.sml │ ├── test32.sml │ └── test64.sml ├── Logging │ ├── README.md │ ├── log.sml │ ├── phase-timer.sml │ ├── sources.cm │ └── stats.sml └── Stamps │ └── stamp.sml └── tools └── MakeFragments ├── README.md ├── main.sml ├── mkfrags.sml ├── sources.cm └── sources.mlb /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | *.ko 4 | *.obj 5 | *.elf 6 | 7 | # Precompiled Headers 8 | *.gch 9 | *.pch 10 | 11 | # Libraries 12 | *.lib 13 | *.a 14 | *.la 15 | *.lo 16 | 17 | # Shared objects (inc. Windows DLLs) 18 | *.dll 19 | *.so 20 | *.so.* 21 | *.dylib 22 | 23 | # Executables 24 | *.exe 25 | *.out 26 | *.app 27 | *.i*86 28 | *.x86_64 29 | *.hex 30 | 31 | # Debug files 32 | *.dSYM/ 33 | 34 | # macOS finder 35 | .DS_Store 36 | 37 | # SML/NJ 38 | .cm/ 39 | 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016-2017 John Reppy 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities 2 | 3 | This project collects together a bunch of utility modules and code-generation 4 | tools that I've used over the years in various compiler projects. The code is 5 | written in Standard ML (as are the tools) and assumes the presence of the 6 | SML/NJ library. 7 | 8 | ### Roadmap 9 | 10 | The code is organized into two subdirectories: `libsrc`, which contains the various SML 11 | utility modules, and `tools`, which contains some code generation tools. 12 | 13 | #### Libraries 14 | 15 | * [CodeTemplates](libsrc/CodeTemplates/README.md) -- 16 | Infrastructure for supporting textual code snippits with substitutions. This 17 | code supports the [Make Fragments](#make-fragments) tool descrbied below. 18 | 19 | * [Constant arithemetic](libsrc/ConstArith/README.md) -- Infrastructure for 20 | constant-folding integer arithmetic at different precisions. 21 | 22 | * [Errors](libsrc/Errors/README.md) -- error tracking for 23 | [ML-LPT](http://smlnj.org/doc/ml-lpt/manual.pdf) based parsers 24 | 25 | * [Floats](libsrc/Floats/README.md) -- A representation of floating-point 26 | literals plus support for converting to IEEE binary representations. 27 | 28 | * [Logging](libsrc/Logging/README.md) -- Utility code for log messages and 29 | for timing compiler phases. 30 | 31 | * Stamps -- unique stamps for tagging identifiers and other semantic objects 32 | 33 | #### Tools 34 | 35 | * [MakeFragments](tools/MakeFragments/README.md) -- 36 | This directory contains tools for converting source-code fragments into 37 | SML string constants in an SML module. 38 | -------------------------------------------------------------------------------- /libsrc/CodeTemplates/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Code Templates 2 | 3 | This directory contains support for inserting textual code fragments 4 | with substitutions into generated files. The associated 5 | [make-fragments](../../tools/MakeFragments/README.md) tool can be used 6 | to generate the fragment strings from source files. 7 | 8 | The basic operation is 9 | 10 | ````sml 11 | CodeTemplate.expand substitutions text 12 | ```` 13 | 14 | which expands the string `text` by replacing *placeholders* with their expansion as 15 | specified in the list of id-value pairs `substitutions`. Placeholders in `text` 16 | have the syntax `@`<id>`@` and are replaced with the string associated with 17 | <id> in the list `substitutions`. If <id> is empty, then no substitution 18 | is applied, instead the `"@@"` is replaced by `"@"`. 19 | 20 | I often use this mechanism to handle boilerplate code in compilers 21 | that generate source code in a language like SML, C, or C++. 22 | -------------------------------------------------------------------------------- /libsrc/CodeTemplates/code-template.sml: -------------------------------------------------------------------------------- 1 | (* code-template.sml 2 | * 3 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 4 | * 5 | * Permission is hereby granted, free of charge, to any person obtaining a copy 6 | * of this software and associated documentation files (the "Software"), to deal 7 | * in the Software without restriction, including without limitation the rights 8 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | * copies of the Software, and to permit persons to whom the Software is 10 | * furnished to do so, subject to the following conditions: 11 | * 12 | * The above copyright notice and this permission notice shall be included in all 13 | * copies or substantial portions of the Software. 14 | * 15 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | * SOFTWARE. 22 | * 23 | * This code is part of the SML Compiler Utilities, which can be found at 24 | * 25 | * https://github.com/JohnReppy/sml-compiler-utils 26 | *) 27 | 28 | structure CodeTemplate : sig 29 | 30 | (* `expand substitutions text` 31 | * expand the string `text` by replacing placeholders with their expansion as 32 | * specified in the list of id-value pairs `substitutions`. Placeholders in `text` 33 | * have the syntax @@ and are replaced with the string associated with 34 | * in the list `substitutions`. If is empty, then no substitution 35 | * is applied, instead the "@@" is replaced by "@". 36 | *) 37 | val expand : (string * string) list -> string -> string 38 | 39 | end = struct 40 | 41 | structure SS = Substring 42 | structure Tbl = HashTableFn ( 43 | struct 44 | type hash_key = substring 45 | val hashVal = HashString.hashSubstring 46 | fun sameKey (ss1, ss2) = (SS.compare (ss1, ss2) = EQUAL) 47 | end) 48 | 49 | fun expand subs = let 50 | val find = let 51 | val tbl = Tbl.mkTable (List.length subs, Fail "subst-tbl") 52 | fun ins ("", _) = raise Fail "Illegal empty placeholder" 53 | | ins (s1, s2) = Tbl.insert tbl (SS.full s1, s2) 54 | in 55 | Tbl.insert tbl (SS.full "", "@"); 56 | List.app ins subs; 57 | Tbl.find tbl 58 | end 59 | fun scan (start, ss, n, frags) = (case SS.getc ss 60 | of SOME(#"@", rest) => let 61 | val frags = SS.slice(start, 0, SOME n) :: frags 62 | val (expansion, rest) = scanPlaceholder rest 63 | in 64 | scan (rest, rest, 0, expansion::frags) 65 | end 66 | | SOME(_, rest) => scan (start, rest, n+1, frags) 67 | | NONE => SS.concat(List.rev(start::frags)) 68 | (* end case *)) 69 | and scanPlaceholder start = let 70 | fun scan (ss, n) = (case SS.getc ss 71 | of NONE => raise Fail "incomplete placeholder" 72 | | SOME(#"@", rest) => (SS.slice(start, 0, SOME n), rest) 73 | | SOME(_, rest) => scan (rest, n+1) 74 | (* end case *)) 75 | val (placeholder, rest) = scan (start, 0) 76 | in 77 | case find placeholder 78 | of SOME expansion => (SS.full expansion, rest) 79 | | NONE => raise Fail(concat[ 80 | "unknown placeholder @", SS.string placeholder, "@" 81 | ]) 82 | (* end case *) 83 | end 84 | fun expandStr s = let 85 | val ss = SS.full s 86 | in 87 | scan (ss, ss, 0, []) 88 | end 89 | in 90 | expandStr 91 | end 92 | 93 | end 94 | -------------------------------------------------------------------------------- /libsrc/ConstArith/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Constant Arithmetic 2 | 3 | Many compilers perform compile-time arithmetic on constants as an optimization. 4 | While such optimizations may seem trivial to implement, there are a number of 5 | pesky details that must be addressed. These include supporting varying precisions, 6 | signed vs. unsigned operations, and wrapping vs. trapping on overflow. This 7 | library provides a collection of modules that support these optimizations and 8 | which support a choice of semantics for arithmetic operations. 9 | 10 | ### The API 11 | 12 | Our basic assumption is that compile-time integer constants are represented as 13 | the **SML** type `IntInf.int` (*i.e.*, arbitrary-precision integers). 14 | 15 | Operations are grouped into three signatures: 16 | 17 | * `BITWISE_CONST_ARITH` -- these operations implement bitwise operations. They 18 | support both signed and unsigned values and interpret negative arguments as 19 | having a 2's complement representation in bits. For bitwidth of WID, values 20 | should be in the range -2^(WID-1)^ to 2^WID^-1 (note the asymmetry). 21 | 22 | * `SIGNED_CONST_ARITH` -- these operations implement signed arithmetic. For 23 | a bitwidth of WID, values should be in the range -2^(WID-1)^ to 2^(WID-1)^-1. 24 | 25 | * `UNSIGNED_CONST_ARITH` -- these operations implement unsigned arithmetic. For 26 | a bitwidth of WID, values should be in the range 0 to 2^WID^-1. 27 | 28 | The `CONST_ARITH` signature is a union of these three signatures. 29 | 30 | ### Implementations 31 | 32 | The signed and unsigned arithmetic signatures have two implementations: 33 | a *trapping* implementation where the `Overflow` exception is raised when 34 | values are too large to be represented in the specified number of bits, and 35 | a *wrapping* implementation, where results are narrowed to the specified precision. 36 | 37 | ````sml 38 | structure BitwiseConstArith : BITWISE_CONST_ARITH 39 | 40 | structure SignedTrappingArith : SIGNED_CONST_ARITH 41 | structure SignedWrappingArith : SIGNED_CONST_ARITH 42 | 43 | structure UnsignedTrappingArith : UNSIGNED_CONST_ARITH 44 | structure UnsignedWrappingArith : UNSIGNED_CONST_ARITH 45 | ```` 46 | 47 | In addition, the `ConstArithGlueFn` functor can be used to glue three modules into an 48 | implementation of the `CONST_ARITH` signature. 49 | 50 | ````sml 51 | functor ConstArithGlueFn ( 52 | structure B : BITWISE_CONST_ARITH 53 | structure S : SIGNED_CONST_ARITH 54 | structure U : UNSIGNED_CONST_ARITH 55 | ) : CONST_ARITH 56 | ```` 57 | 58 | Lastly, there are functors that wrap the three types of arithmetic modules with 59 | error checking of the arguments. These are meant to be used when one wants to 60 | include internal consistency checking in one's compiler. 61 | 62 | ````sml 63 | functor CheckBitwiseArithFn ( 64 | structure A : BITWISE_CONST_ARITH 65 | val qual : string 66 | val error : string -> 'a 67 | ) : BITWISE_CONST_ARITH 68 | 69 | functor CheckSignedArithFn ( 70 | structure A : SIGNED_CONST_ARITH 71 | val qual : string 72 | val error : string -> 'a 73 | ) : SIGNED_CONST_ARITH 74 | 75 | functor CheckUnsignedArithFn ( 76 | structure A : UNSIGNED_CONST_ARITH 77 | val qual : string 78 | val error : string -> 'a 79 | ) : UNSIGNED_CONST_ARITH 80 | ```` 81 | 82 | The `A` structure argument is the structure being wrapped; the `qual` argument 83 | is typically the name of the structure with a trailing period (*e.g.*, `"BitwiseTrappingArith."`); 84 | and the `error` argument is a function for reporting errors. The `error` function 85 | is not expected to return. For example, we can define an implementation of bitwise 86 | arithmetic that checks that its arguments are within range as follows: 87 | 88 | ```sml 89 | structure BitwiseArith = CheckBitwiseArithFn ( 90 | structure A = BitwiseWrappingArith 91 | val qual = "BitwiseWrappingArith." 92 | fun error msg = raise Fail msg) 93 | ``` 94 | 95 | ### Examples 96 | 97 | In languages like **C** and **C++**, integer arithmetic is non-trapping. We can define 98 | an instatiation of the `CONST_ARITH` interface for these languages by using the wrapping 99 | implementations: 100 | 101 | ````sml 102 | structure CArith = ConstArithGlueFn ( 103 | structure B = BitwiseConstArith 104 | structure S = SignedWrappingArith 105 | structure U = UnsignedWrappingArith) 106 | ```` 107 | 108 | In Standard ML, however, the semantics of arithmetic is more complicated, since signed operations 109 | are trapping, while unsigned operations (*i.e.*, `word` operations) wrap. 110 | 111 | ````sml 112 | structure SMLArith = ConstArithGlueFn ( 113 | structure B = BitwiseConstArith 114 | structure S = SignedTrappingArith 115 | structure U = UnsignedWrappingArith) 116 | ```` 117 | 118 | ### Roadmap 119 | 120 | * `README.md` -- this file 121 | * `bitwise-const-arith-sig.sml` -- the `BITWISE_CONST_ARITH` signature 122 | * `bitwise-const-arith.sml` -- the `BitwiseConstArith` structure 123 | * `check-bitwise-arith-fn.sml` -- the `CheckBitwiseArithFn` functor 124 | * `check-signed-arith-fn.sml` -- the `CheckSignedArithFn` functor 125 | * `check-unsigned-arith-fn.sml` -- the `CheckUnsignedArithFn` functor 126 | * `const-arith-glue-fn.sml` -- the `ConstArithGlueFn` functor 127 | * `const-arith-sig.sml` -- the `CONST_ARITH` signature 128 | * `signed-const-arith-sig.sml` -- the `SIGNED_CONST_ARITH` signature 129 | * `signed-trapping-arith.sml` -- the `SignedTrappingArith` structure 130 | * `signed-wrapping-arith.sml` -- the `SignedWrappingArith` structure 131 | * `sources.cm` -- CM file for compiling the code 132 | * `test.cm` -- CM code for testing the code 133 | * `test.sml` -- test cases 134 | * `unsigned-const-arith-sig.sml` -- the `UNSIGNED_CONST_ARITH` signature 135 | * `unsigned-trapping-arith.sml` -- the `UnsignedTrappingArith` structure 136 | * `unsigned-wrapping-arith.sml` -- the `UnsignedWrappingArith` structure 137 | 138 | -------------------------------------------------------------------------------- /libsrc/ConstArith/bitwise-const-arith-sig.sml: -------------------------------------------------------------------------------- 1 | (* bitwise-const-arith-sig.sml 2 | * 3 | * Operations for constant-folding bitwise operations on constant integers. 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | signature BITWISE_CONST_ARITH = 32 | sig 33 | 34 | (* we use arbitrary-precision integers to represent constant values *) 35 | type t = IntInf.int 36 | 37 | (* bit-widths are represented as integers *) 38 | type width = int 39 | 40 | val bAnd : width * t * t -> t 41 | val bOr : width * t * t -> t 42 | val bXor : width * t * t -> t 43 | val bNot : width * t -> t 44 | 45 | end 46 | -------------------------------------------------------------------------------- /libsrc/ConstArith/bitwise-const-arith.sml: -------------------------------------------------------------------------------- 1 | (* bitwise-const-arith.sml 2 | * 3 | * Operations for constant-folding bitwise operations on constant integers. 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure BitwiseConstArith : BITWISE_CONST_ARITH = 32 | struct 33 | 34 | (* we use arbitrary-precision integers to represent constant values *) 35 | type t = IntInf.int 36 | 37 | (* bit-widths are represented as integers *) 38 | type width = int 39 | 40 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 41 | 42 | fun narrow (wid, n) = IntInf.andb(n, pow2 wid - 1) 43 | 44 | fun bAnd (wid, a, b) = narrow (wid, IntInf.andb(a, b)) 45 | fun bOr (wid, a, b) = narrow (wid, IntInf.orb(a, b)) 46 | fun bXor (wid, a, b) = narrow (wid, IntInf.xorb(a, b)) 47 | fun bNot (wid, a) = narrow (wid, IntInf.xorb(a, pow2 wid - 1)) 48 | 49 | end 50 | -------------------------------------------------------------------------------- /libsrc/ConstArith/check-bitwise-arith-fn.sml: -------------------------------------------------------------------------------- 1 | (* check-bitwise-arith-fn.sml 2 | * 3 | * A wrapper functor for implementations of the BITWISE_CONST_ARITH signature, 4 | * which adds validity checking of the arguments. 5 | * 6 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | functor CheckBitwiseArithFn ( 33 | 34 | (* implementation to be checked *) 35 | structure A : BITWISE_CONST_ARITH 36 | 37 | (* should be the name of the structure that A is bound to with trailing ".", but "" 38 | * is also okay. 39 | *) 40 | val qual : string 41 | 42 | (* function for reporting the error; this function should raise the appropriate exception *) 43 | val error : string -> 'a 44 | 45 | ) : BITWISE_CONST_ARITH = 46 | struct 47 | 48 | type t = A.t 49 | type width = A.width 50 | 51 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 52 | 53 | fun chkWid err w = if (w < 1) then err() else w 54 | fun chkArg err w = let val limit = pow2 w 55 | in 56 | fn n => if (n < 0) orelse (limit <= n) then err() else n 57 | end 58 | 59 | fun chk1 name f (w, arg) = let 60 | fun err () = error(concat[ 61 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg, ")'" 62 | ]) 63 | in 64 | f (chkWid err w, chkArg err w arg) 65 | end 66 | 67 | fun chk2 name f (w, arg1, arg2) = let 68 | fun err () = error(concat[ 69 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg1, ", ", 70 | IntInf.toString arg2, ")'" 71 | ]) 72 | val chkArg = chkArg err w 73 | in 74 | f (chkWid err w, chkArg arg1, chkArg arg2) 75 | end 76 | 77 | val bAnd = chk2 "bAnd" A.bAnd 78 | val bOr = chk2 "bOr" A.bOr 79 | val bXor = chk2 "bXor" A.bXor 80 | val bNot = chk1 "nNot" A.bNot 81 | 82 | end 83 | -------------------------------------------------------------------------------- /libsrc/ConstArith/check-signed-arith-fn.sml: -------------------------------------------------------------------------------- 1 | (* check-signed-arith-fn.sml 2 | * 3 | * A wrapper functor for implementations of the SIGNED_CONST_ARITH signature, 4 | * which adds validity checking of the arguments. 5 | * 6 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | functor CheckSignedArithFn ( 33 | 34 | (* implementation to be checked *) 35 | structure A : SIGNED_CONST_ARITH 36 | 37 | (* should be the name of the structure that A is bound to with trailing ".", but "" 38 | * is also okay. 39 | *) 40 | val qual : string 41 | 42 | (* function for reporting the error; this function should raise the appropriate exception *) 43 | val error : string -> 'a 44 | 45 | ) : SIGNED_CONST_ARITH = 46 | struct 47 | 48 | type t = A.t 49 | type width = A.width 50 | 51 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 52 | 53 | fun chkWid err w = if (w < 1) then err() else w 54 | fun chkArg err w = let 55 | val limit = pow2 (w-1) 56 | in 57 | fn n => if (n < ~limit) orelse (limit <= n) then err() else n 58 | end 59 | 60 | fun chk1 name f (w, arg) = let 61 | fun err () = error(concat[ 62 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg, ")'" 63 | ]) 64 | in 65 | f (chkWid err w, chkArg err w arg) 66 | end 67 | 68 | fun chk2 name f (w, arg1, arg2) = let 69 | fun err () = error(concat[ 70 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg1, ", ", 71 | IntInf.toString arg2, ")'" 72 | ]) 73 | val chkArg = chkArg err w 74 | in 75 | f (chkWid err w, chkArg arg1, chkArg arg2) 76 | end 77 | 78 | fun sNarrow (w, n) = 79 | (* no checking of second argument because A.sNarrow does that *) 80 | if (w < 1) 81 | then error(concat[ 82 | "'", qual, "sNarrow(", Int.toString w, ", ", IntInf.toString n, ")'" 83 | ]) 84 | else A.sNarrow (w, n) 85 | 86 | (* converts values in range 0..pow2(width)-1 to -pow2(width-1)..pow2(width-1)-1 *) 87 | fun toSigned (w, n) = 88 | if (w < 1) orelse (n < 0) orelse (pow2 w <= n) 89 | then error(concat[ 90 | "'", qual, "toSigned(", Int.toString w, ", ", IntInf.toString n, ")'" 91 | ]) 92 | else A.toSigned (w, n) 93 | 94 | val sAdd = chk2 "sAdd" A.sAdd 95 | val sSub = chk2 "sSub" A.sSub 96 | val sMul = chk2 "sMul" A.sMul 97 | val sDiv = chk2 "sDiv" A.sDiv 98 | val sMod = chk2 "sMod" A.sMod 99 | val sQuot = chk2 "sQuot" A.sQuot 100 | val sRem = chk2 "sRem" A.sRem 101 | val sNeg = chk1 "sNeg" A.sNeg 102 | val sAbs = chk1 "sAbs" A.sAbs 103 | 104 | fun chkShift name f (w, arg, shft) = let 105 | fun err () = error(concat[ 106 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg, ", ", 107 | IntInf.toString shft, ")'" 108 | ]) 109 | in 110 | if (shft < 0) orelse (pow2 w <= shft) 111 | then err () 112 | else f (chkWid err w, chkArg err w arg, shft) 113 | end 114 | 115 | val sShL = chk2 "sShL" A.sShL 116 | val sShR = chk2 "sShR" A.sShR 117 | 118 | end 119 | -------------------------------------------------------------------------------- /libsrc/ConstArith/check-unsigned-arith-fn.sml: -------------------------------------------------------------------------------- 1 | (* check-unsigned-arith-fn.sml 2 | * 3 | * A wrapper functor for implementations of the UNSIGNED_CONST_ARITH signature, 4 | * which adds validity checking of the arguments. 5 | * 6 | * COPYRIGHT (c) 2025 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | functor CheckUnsignedArithFn ( 33 | 34 | (* implementation to be checked *) 35 | structure A : UNSIGNED_CONST_ARITH 36 | 37 | (* should be the name of the structure that A is bound to with trailing ".", but "" 38 | * is also okay. 39 | *) 40 | val qual : string 41 | 42 | (* function for reporting the error; this function should raise the appropriate exception *) 43 | val error : string -> 'a 44 | 45 | ) : UNSIGNED_CONST_ARITH = 46 | struct 47 | 48 | type t = A.t 49 | type width = A.width 50 | 51 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 52 | 53 | fun chkWid err w = if (w < 1) then err() else w 54 | fun chkArg err w = let 55 | val limit = pow2 w 56 | in 57 | fn n => if (n < 0) orelse (limit <= n) then err() else n 58 | end 59 | 60 | fun chk1 name f (w, arg) = let 61 | fun err () = error(concat[ 62 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg, ")'" 63 | ]) 64 | in 65 | f (chkWid err w, chkArg err w arg) 66 | end 67 | 68 | fun chk2 name f (w, arg1, arg2) = let 69 | fun err () = error(concat[ 70 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg1, ", ", 71 | IntInf.toString arg2, ")'" 72 | ]) 73 | val chkArg = chkArg err w 74 | in 75 | f (chkWid err w, chkArg arg1, chkArg arg2) 76 | end 77 | 78 | (* narrow an unsigned value to the range 0..2^WID^-1; depending on the semantics 79 | * of the implementation, this function may raise Overflow on values that are 80 | * outside the range -2^(WID-1)^..2^(WID)^-1. 81 | *) 82 | fun uNarrow (w, n) = 83 | (* no checking of second argument because A.sNarrow does that *) 84 | if (w < 1) 85 | then error(concat[ 86 | "'", qual, "uNarrow(", Int.toString w, ", ", IntInf.toString n, ")'" 87 | ]) 88 | else A.uNarrow (w, n) 89 | 90 | (* converts values in range -2^(WID-1)^..2^(WID-1)^-1 to 0..2^(WID)^-1 *) 91 | fun toUnsigned (w, n) = let 92 | val limit = pow2 (w-1) 93 | in 94 | if (w < 1) orelse (n < ~limit) orelse (limit <= n) 95 | then error(concat[ 96 | "'", qual, "toUnsigned(", Int.toString w, ", ", IntInf.toString n, ")'" 97 | ]) 98 | else A.toUnsigned (w, n) 99 | end 100 | 101 | val uAdd = chk2 "uAdd" A.uAdd 102 | val uSub = chk2 "uSub" A.uSub 103 | val uMul = chk2 "uMul" A.uMul 104 | val uDiv = chk2 "uDiv" A.uDiv 105 | val uMod = chk2 "uMod" A.uMod 106 | val uNeg = chk1 "uNeg" A.uNeg 107 | 108 | fun chkShift name f (w, arg, shft) = let 109 | fun err () = error(concat[ 110 | "'", qual, name, "(", Int.toString w, ", ", IntInf.toString arg, ", ", 111 | IntInf.toString shft, ")'" 112 | ]) 113 | in 114 | if (shft < 0) orelse (pow2 w <= shft) 115 | then err () 116 | else f (chkWid err w, chkArg err w arg, shft) 117 | end 118 | 119 | val uShL = chk2 "uShL" A.uShL 120 | val uShR = chk2 "uShR" A.uShR 121 | 122 | val uEq = chk2 "uEq" A.uEq 123 | val uLess = chk2 "uLess" A.uLess 124 | val uLessEq = chk2 "uLess" A.uLessEq 125 | 126 | end 127 | -------------------------------------------------------------------------------- /libsrc/ConstArith/const-arith-glue-fn.sml: -------------------------------------------------------------------------------- 1 | (* const-arith-glue-fn.sml 2 | * 3 | * A functor for gluing together implementations of signed, unsigned, and bitwise 4 | * operations into a single structure. 5 | * 6 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | functor ConstArithGlueFn ( 33 | structure S : SIGNED_CONST_ARITH 34 | structure U : UNSIGNED_CONST_ARITH 35 | structure B : BITWISE_CONST_ARITH 36 | ) : CONST_ARITH = 37 | struct 38 | 39 | type t = IntInf.int 40 | type width = int 41 | 42 | open S U B 43 | 44 | end 45 | 46 | 47 | -------------------------------------------------------------------------------- /libsrc/ConstArith/const-arith-sig.sml: -------------------------------------------------------------------------------- 1 | (* const-arith-sig.sml 2 | * 3 | * A generic interface for constant-folding fixed-precision integer arithmetic. 4 | * Implementations with different semantics for overflow are provided. 5 | * 6 | * COPYRIGHT (c) 2025 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | signature CONST_ARITH = 33 | sig 34 | 35 | (* we use arbitrary-precision integers to represent constant values *) 36 | type t = IntInf.int 37 | 38 | (* bit-widths are represented as integers *) 39 | type width = int 40 | 41 | (* narrow a signed-constant to fit within the given number of bits. Depending on the 42 | * semantics of the structure implementing this signature, this operation may raise 43 | * Overflow. 44 | *) 45 | val sNarrow : width * t -> t 46 | 47 | (* signed arithmetic *) 48 | val sAdd : width * t * t -> t 49 | val sSub : width * t * t -> t 50 | val sMul : width * t * t -> t 51 | val sDiv : width * t * t -> t (* division (round toward -∞) *) 52 | val sMod : width * t * t -> t (* sMod(n, m) = n - m*sDiv(n, m) *) 53 | val sQuot : width * t * t -> t (* division (round toward 0) *) 54 | val sRem : width * t * t -> t (* sRem(n, m) = n - m*sQuot(n, m) *) 55 | val sShL : width * t * t -> t (* shift left *) 56 | val sShR : width * t * t -> t (* shift right (sign-extend) *) 57 | val sNeg : width * t -> t (* unary negation *) 58 | val sAbs : width * t -> t (* absolute value *) 59 | 60 | (* narrow an unsigned-constant to fit within the given number of bits. Depending on 61 | * the semantics of the structure implementing this signature, this operation may 62 | * raise Overflow. 63 | *) 64 | val uNarrow : int * IntInf.int -> IntInf.int 65 | 66 | (* unsigned arithmetic. We assume that the arguments are non-negative *) 67 | val uAdd : width * t * t -> t 68 | val uSub : width * t * t -> t 69 | val uMul : width * t * t -> t 70 | val uDiv : width * t * t -> t (* division (round toward 0) *) 71 | val uMod : width * t * t -> t (* uMod(n, m) = n - m*uDiv(n, m) *) 72 | val uShL : width * t * t -> t (* shift left *) 73 | val uShR : width * t * t -> t (* shift right (zero-extend) *) 74 | 75 | (* 2's complement of argument as unsigned value *) 76 | val uNeg : width * t -> t 77 | 78 | (* unsigned comparisons, which correctly handle negative arguments *) 79 | val uEq : width * t * t -> bool 80 | val uLess : width * t * t -> bool 81 | val uLessEq : width * t * t -> bool 82 | 83 | (* bitwise operations (these never trap) *) 84 | val bAnd : width * t * t -> t 85 | val bOr : width * t * t -> t 86 | val bXor : width * t * t -> t 87 | val bNot : width * t -> t 88 | 89 | (* conversions between signed and unsigned interpretations *) 90 | val toSigned : width * t -> t (* unsigned -> signed; uses sNarrow for overflow checking *) 91 | val toUnsigned : width * t -> t (* signed -> unsigned *) 92 | 93 | end 94 | 95 | -------------------------------------------------------------------------------- /libsrc/ConstArith/signed-const-arith-sig.sml: -------------------------------------------------------------------------------- 1 | (* signed-const-arith-sig.sml 2 | * 3 | * Operations for constant-folding bitwise operations on constant integers. 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | signature SIGNED_CONST_ARITH = 32 | sig 33 | 34 | (* we use arbitrary-precision integers to represent constant values *) 35 | type t = IntInf.int 36 | 37 | (* bit-widths are represented as integers *) 38 | type width = int 39 | 40 | (* narrow a signed-constant to fit within the range -2^(WID-1)^..2^(WID-1)^-1. 41 | * Depending on the semantics of the implementation, this operation may raise 42 | * Overflow on values that are outside the range -2^(WID-1)^..2^(WID-1)^. 43 | *) 44 | val sNarrow : width * t -> t 45 | 46 | (* converts values in range 0..pow2(width)-1 to -pow2(width-1)..pow2(width-1)-1 *) 47 | val toSigned : width * t -> t 48 | 49 | val sAdd : width * t * t -> t 50 | val sSub : width * t * t -> t 51 | val sMul : width * t * t -> t 52 | val sDiv : width * t * t -> t (* division (round toward -∞) *) 53 | val sMod : width * t * t -> t (* sMod(n, m) = n - m*sDiv(n, m) *) 54 | val sQuot : width * t * t -> t (* division (round toward 0) *) 55 | val sRem : width * t * t -> t (* sRem(n, m) = n - m*sQuot(n, m) *) 56 | val sShL : width * t * t -> t (* shift left *) 57 | val sShR : width * t * t -> t (* shift right (sign-extend) *) 58 | val sNeg : width * t -> t (* unary negation *) 59 | val sAbs : width * t -> t (* absolute value *) 60 | 61 | end 62 | -------------------------------------------------------------------------------- /libsrc/ConstArith/signed-trapping-arith.sml: -------------------------------------------------------------------------------- 1 | (* signed-trapping-arith.sml 2 | * 3 | * Implements signed, trapping arithmetic. 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure SignedTrappingArith : SIGNED_CONST_ARITH = 32 | struct 33 | 34 | type t = IntInf.int 35 | type width = int 36 | 37 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 38 | 39 | (* narrow the representation of n to `wid` bits, which just means checking if it is 40 | * representable and raising Overflow if not. 41 | *) 42 | fun sNarrow (wid, n) = let 43 | val limit = pow2(wid - 1) 44 | in 45 | if (n < ~limit) orelse (limit <= n) 46 | then raise Overflow 47 | else n 48 | end 49 | 50 | fun toSigned (wid, a) = if a < pow2(wid - 1) 51 | then a 52 | else a - pow2 wid 53 | 54 | fun sAdd (wid, a, b) = sNarrow (wid, a + b) 55 | fun sSub (wid, a, b) = sNarrow (wid, a - b) 56 | fun sMul (wid, a, b) = sNarrow (wid, a * b) 57 | fun sDiv (wid, a, b) = sNarrow (wid, a div b) 58 | fun sMod (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 59 | | sMod (wid, a, b) = sNarrow (wid, a mod b) 60 | fun sQuot (wid, a, b) = sNarrow (wid, IntInf.quot(a, b)) 61 | fun sRem (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 62 | | sRem (wid, a, b) = sNarrow (wid, IntInf.rem(a, b)) 63 | fun sNeg (wid, a) = sNarrow (wid, ~a) 64 | fun sAbs (wid, a) = if (a < 0) then sNarrow (wid, ~a) else a 65 | 66 | (* signed left-shift operation. *) 67 | fun sShL (wid, 0, _) = 0 68 | | sShL (wid, a, b) = 69 | if (b >= IntInf.fromInt wid) 70 | then raise Overflow 71 | else sNarrow (wid, IntInf.<<(a, Word.fromLargeInt b)) 72 | 73 | (* signed right-shift operation. Shift amounts that are >= wid result in zero. *) 74 | fun sShR (wid, a, b) = let 75 | val shft = Word.fromLargeInt(IntInf.min(b, IntInf.fromInt wid)) 76 | in 77 | sNarrow (wid, IntInf.~>>(a, shft)) 78 | end 79 | 80 | end 81 | -------------------------------------------------------------------------------- /libsrc/ConstArith/signed-wrapping-arith.sml: -------------------------------------------------------------------------------- 1 | (* signed-wrapping-arith.sml 2 | * 3 | * Implements signed, trapping arithmetic. 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure SignedWrappingArith : SIGNED_CONST_ARITH = 32 | struct 33 | 34 | type t = IntInf.int 35 | type width = int 36 | 37 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 38 | 39 | (* narrow the representation of n to `wid` bits (2's complement). This behaves 40 | * like a C-style cast to a signed integer type. 41 | *) 42 | fun sNarrow (wid, n) = let 43 | val limit = pow2 wid 44 | val n = IntInf.andb(n, limit - 1) 45 | in 46 | if n < pow2(wid - 1) then n else n - limit 47 | end 48 | 49 | fun toSigned (wid, a) = if a < pow2(wid - 1) 50 | then a 51 | else a - pow2 wid 52 | 53 | fun sAdd (wid, a, b) = sNarrow (wid, a + b) 54 | fun sSub (wid, a, b) = sNarrow (wid, a - b) 55 | fun sMul (wid, a, b) = sNarrow (wid, a * b) 56 | fun sDiv (wid, a, b) = sNarrow (wid, a div b) 57 | fun sMod (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 58 | | sMod (wid, a, b) = sNarrow (wid, a mod b) 59 | fun sQuot (wid, a, b) = sNarrow (wid, IntInf.quot(a, b)) 60 | fun sRem (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 61 | | sRem (wid, a, b) = sNarrow (wid, IntInf.rem(a, b)) 62 | fun sNeg (wid, a) = sNarrow (wid, ~a) 63 | fun sAbs (wid, a) = if (a < 0) then sNarrow (wid, ~a) else a 64 | 65 | (* signed left-shift operation. Shift amounts that are >= wid result in zero. *) 66 | fun sShL (wid, a, b) = 67 | if (b >= IntInf.fromInt wid) 68 | then 0 69 | else sNarrow (wid, IntInf.<<(a, Word.fromLargeInt b)) 70 | 71 | (* signed right-shift operation. Shift amounts that are >= wid result in zero. *) 72 | fun sShR (wid, a, b) = let 73 | val shft = Word.fromLargeInt(IntInf.min(b, IntInf.fromInt wid)) 74 | in 75 | sNarrow (wid, IntInf.~>>(a, shft)) 76 | end 77 | 78 | end 79 | -------------------------------------------------------------------------------- /libsrc/ConstArith/sources.cm: -------------------------------------------------------------------------------- 1 | (* sources.cm 2 | * 3 | * CM file to build constant-folding code on SML/NJ. The main purpose of this 4 | * file is to support testing of the library, since it is assumed that users 5 | * of this code will just include the pieces that they find useful in their 6 | * own sources. 7 | * 8 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 9 | * 10 | * Permission is hereby granted, free of charge, to any person obtaining a copy 11 | * of this software and associated documentation files (the "Software"), to deal 12 | * in the Software without restriction, including without limitation the rights 13 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 14 | * copies of the Software, and to permit persons to whom the Software is 15 | * furnished to do so, subject to the following conditions: 16 | * 17 | * The above copyright notice and this permission notice shall be included in all 18 | * copies or substantial portions of the Software. 19 | * 20 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 26 | * SOFTWARE. 27 | * 28 | * This code is part of the SML Compiler Utilities, which can be found at 29 | * 30 | * https://github.com/JohnReppy/sml-compiler-utils 31 | *) 32 | 33 | Library 34 | 35 | signature BITWISE_CONST_ARITH 36 | signature CONST_ARITH 37 | signature SIGNED_CONST_ARITH 38 | signature UNSIGNED_CONST_ARITH 39 | 40 | structure BitwiseConstArith (* bitwise operations *) 41 | 42 | structure SignedTrappingArith (* signed operations with trapping semantics *) 43 | structure SignedWrappingArith (* signed operations with wrapping semantics *) 44 | 45 | structure UnsignedTrappingArith (* unsigned operations with trapping semantics *) 46 | structure UnsignedWrappingArith (* unsigned operations with wrapping semantics *) 47 | 48 | (* functor for gluing together different implementations into a single module that 49 | * implements the CONST_ARITH signature 50 | *) 51 | functor ConstArithGlueFn 52 | 53 | (* functors for checking the arguments to the various operations *) 54 | functor CheckBitwiseArithFn 55 | functor CheckSignedArithFn 56 | functor CheckUnsignedArithFn 57 | 58 | is 59 | 60 | $/basis.cm 61 | $/smlnj-lib.cm 62 | 63 | bitwise-const-arith-sig.sml 64 | bitwise-const-arith.sml 65 | check-bitwise-arith-fn.sml 66 | check-signed-arith-fn.sml 67 | check-unsigned-arith-fn.sml 68 | const-arith-glue-fn.sml 69 | const-arith-sig.sml 70 | signed-const-arith-sig.sml 71 | signed-trapping-arith.sml 72 | signed-wrapping-arith.sml 73 | unsigned-const-arith-sig.sml 74 | unsigned-trapping-arith.sml 75 | unsigned-wrapping-arith.sml 76 | -------------------------------------------------------------------------------- /libsrc/ConstArith/test.cm: -------------------------------------------------------------------------------- 1 | (* test.cm 2 | * 3 | * CM file to build and run tests of the constant-arithmetic modules 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | Library 31 | 32 | structure TestBitwiseArith 33 | 34 | structure TestSignedTrapping 35 | structure TestSignedWrapping 36 | 37 | structure TestUnsignedWrapping 38 | structure TestUnsignedTrapping 39 | 40 | structure TestAll 41 | 42 | is 43 | 44 | $/basis.cm 45 | 46 | sources.cm 47 | 48 | test.sml 49 | -------------------------------------------------------------------------------- /libsrc/ConstArith/unsigned-const-arith-sig.sml: -------------------------------------------------------------------------------- 1 | (* unsigned-const-arith-sig.sml 2 | * 3 | * Operations for constant-folding unsigned operations on constant integers. 4 | * 5 | * COPYRIGHT (c) 2025 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * All rights reserved. 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | signature UNSIGNED_CONST_ARITH = 32 | sig 33 | 34 | (* we use arbitrary-precision integers to represent constant values *) 35 | type t = IntInf.int 36 | 37 | (* bit-widths are represented as integers *) 38 | type width = int 39 | 40 | (* narrow an unsigned value to the range 0..2^WID^-1; depending on the semantics 41 | * of the implementation, this function may raise Overflow on values that are 42 | * outside the range -2^(WID-1)^..2^(WID)^-1. 43 | *) 44 | val uNarrow : width * t -> t 45 | 46 | (* converts values in range -2^(WID-1)^..2^(WID-1)^-1 to 0..2^(WID)^-1 *) 47 | val toUnsigned : width * t -> t 48 | 49 | val uAdd : width * t * t -> t 50 | val uSub : width * t * t -> t 51 | val uMul : width * t * t -> t 52 | val uDiv : width * t * t -> t 53 | val uMod : width * t * t -> t 54 | val uShL : width * t * t -> t (* shift left *) 55 | val uShR : width * t * t -> t (* shift right (zero-extend) *) 56 | 57 | (* 2's complement of argument as unsigned value *) 58 | val uNeg : width * t -> t 59 | 60 | (* unsigned comparisons, which correctly handle negative arguments *) 61 | val uEq : width * t * t -> bool 62 | val uLess : width * t * t -> bool 63 | val uLessEq : width * t * t -> bool 64 | 65 | end 66 | -------------------------------------------------------------------------------- /libsrc/ConstArith/unsigned-trapping-arith.sml: -------------------------------------------------------------------------------- 1 | (* unsigned-trapping-arith.sml 2 | * 3 | * Implements unsigned arithmetic. Results that are out of range wrap (e.g., 4 | * max-int + 1 = 0) result in the Overflow exception being raised. 5 | * 6 | * COPYRIGHT (c) 2025 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | structure UnsignedTrappingArith : UNSIGNED_CONST_ARITH = 33 | struct 34 | 35 | type t = IntInf.int 36 | type width = int 37 | 38 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 39 | 40 | fun uNarrow (wid, n) = if (n < 0) orelse (pow2 wid <= n) 41 | then raise Overflow 42 | else n 43 | 44 | fun toUnsigned (wid, n) = IntInf.andb(n, pow2 wid - 1) 45 | 46 | fun uAdd (wid, a, b) = uNarrow (wid, a + b) 47 | fun uSub (wid, a, b) = uNarrow (wid, a - b) 48 | fun uMul (wid, a, b) = uNarrow (wid, a * b) 49 | fun uDiv (wid, a, b) = uNarrow (wid, IntInf.quot(a, b)) 50 | fun uMod (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 51 | | uMod (wid, a, b) = uNarrow (wid, IntInf.rem(a, b)) 52 | 53 | (* 2's complement of unsigned argument as unsigned value *) 54 | fun uNeg (wid, a) = let 55 | val mask = pow2 wid - 1 56 | in 57 | IntInf.andb(mask, IntInf.xorb(mask, a) + 1) 58 | end 59 | 60 | (* unsigned left-shift operation. *) 61 | fun uShL (wid, a, b) = 62 | uNarrow (wid, IntInf.<<(a, Word.fromLargeInt(IntInf.min(b, IntInf.fromInt wid)))) 63 | 64 | (* unsigned right-shift operation. Shift amounts that are >= wid result in zero. *) 65 | fun uShR (wid, a, b) = 66 | if (b >= IntInf.fromInt wid) 67 | then 0 68 | else IntInf.~>>(a, Word.fromLargeInt b) 69 | 70 | (* unsigned comparisons *) 71 | fun uEq (wid, a, b) = (toUnsigned(wid, a) = toUnsigned(wid, b)) 72 | fun uLess (wid, a, b) = (toUnsigned(wid, a) < toUnsigned(wid, b)) 73 | fun uLessEq (wid, a, b) = (toUnsigned(wid, a) <= toUnsigned(wid, b)) 74 | 75 | end 76 | -------------------------------------------------------------------------------- /libsrc/ConstArith/unsigned-wrapping-arith.sml: -------------------------------------------------------------------------------- 1 | (* unsigned-wrapping-arith.sml 2 | * 3 | * Implements unsigned arithmetic. Results that are out of range wrap (e.g., 4 | * max-int + 1 = 0). 5 | * 6 | * COPYRIGHT (c) 2025 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * All rights reserved. 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | structure UnsignedWrappingArith : UNSIGNED_CONST_ARITH = 33 | struct 34 | 35 | type t = IntInf.int 36 | type width = int 37 | 38 | fun pow2 w = IntInf.<<(1, Word.fromInt w) 39 | 40 | fun uNarrow (wid, n) = IntInf.andb(n, pow2 wid - 1) 41 | 42 | val toUnsigned = uNarrow 43 | 44 | fun uAdd (wid, a, b) = uNarrow (wid, a + b) 45 | fun uSub (wid, a, b) = uNarrow (wid, a - b) 46 | fun uMul (wid, a, b) = uNarrow (wid, a * b) 47 | fun uDiv (wid, a, b) = uNarrow (wid, IntInf.quot(a, b)) 48 | fun uMod (_, 0, 0) = raise Div (* workaround for bug in SML/NJ pre 110.82 *) 49 | | uMod (wid, a, b) = uNarrow (wid, IntInf.rem(a, b)) 50 | 51 | (* 2's complement of unsigned argument as unsigned value *) 52 | fun uNeg (wid, a) = let 53 | val mask = pow2 wid - 1 54 | in 55 | IntInf.andb(mask, IntInf.xorb(mask, a) + 1) 56 | end 57 | 58 | (* unsigned left-shift operation. Shift amounts that are >= wid result in zero. *) 59 | fun uShL (wid, a, b) = 60 | if (b >= IntInf.fromInt wid) 61 | then 0 62 | else uNarrow (wid, IntInf.<<(a, Word.fromLargeInt b)) 63 | 64 | (* unsigned right-shift operation. Shift amounts that are >= wid result in zero. *) 65 | fun uShR (wid, a, b) = 66 | if (b >= IntInf.fromInt wid) 67 | then 0 68 | else uNarrow (wid, IntInf.~>>(a, Word.fromLargeInt b)) 69 | 70 | (* unsigned comparisons *) 71 | fun uEq (wid, a, b) = (toUnsigned(wid, a) = toUnsigned(wid, b)) 72 | fun uLess (wid, a, b) = (toUnsigned(wid, a) < toUnsigned(wid, b)) 73 | fun uLessEq (wid, a, b) = (toUnsigned(wid, a) <= toUnsigned(wid, b)) 74 | 75 | end 76 | -------------------------------------------------------------------------------- /libsrc/Errors/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Errors 2 | 3 | The `Error` module supports tracking and reporting errors for compilers that use 4 | the [ML-LPT](http://smlnj.org/doc/ml-lpt/manual.pdf) parser tools. 5 | -------------------------------------------------------------------------------- /libsrc/Errors/error.sml: -------------------------------------------------------------------------------- 1 | (* error.sml 2 | * 3 | * Common infrastructure for error reporting. Includes support for error messages 4 | * in ML-ULex generated scanners and ML-Antlr generated parsers. 5 | * 6 | * COPYRIGHT (c) 2021 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure Error :> sig 32 | 33 | (* an exception to raise when hitting an unrecoverable error condition. 34 | * This exception should be caught in the main program. 35 | *) 36 | exception ERROR 37 | 38 | (* logical positions in the input stream *) 39 | type pos = AntlrStreamPos.pos 40 | type span = AntlrStreamPos.span 41 | 42 | type err_stream 43 | 44 | (* `mkErrStream file` make an error stream for the specified file *) 45 | val mkErrStream : string -> err_stream 46 | 47 | val anyErrors : err_stream -> bool 48 | val anyWarnings : err_stream -> bool 49 | val sourceFile : err_stream -> string 50 | val sourceMap : err_stream -> AntlrStreamPos.sourcemap 51 | 52 | (* set a limit on the number of errors allowed; when this limit is exceeded the 53 | * `ERROR` exception will be raised. Setting the limit to zero (or a negative 54 | * number) will clear the limit. 55 | *) 56 | val setErrorLimit : err_stream * int -> unit 57 | 58 | (* add error messages to the error stream. Note that we append a newline onto 59 | * the message, so it is not necessary to end the message with a newline. 60 | *) 61 | val error : err_stream * string list -> unit 62 | val errorAt : err_stream * span * string list -> unit 63 | 64 | (* add warning messages to the error stream. Note that we append a newline onto 65 | * the message, so it is not necessary to end the message with a newline. 66 | *) 67 | val warning : err_stream * string list -> unit 68 | val warningAt : err_stream * span * string list -> unit 69 | 70 | (* add an ml-antlr parse error to the error stream *) 71 | val parseError : (AntlrRepair.add_or_delete -> 'tok -> string) 72 | -> err_stream 73 | -> (pos * 'tok AntlrRepair.repair_action) 74 | -> unit 75 | 76 | (* print the errors to an output stream *) 77 | val report : TextIO.outstream * err_stream -> unit 78 | 79 | (* source-code locations: these are either unknown or specify an interval 80 | * in a source file. 81 | *) 82 | datatype location 83 | = UNKNOWN 84 | | LOC of {file : string, l1 : int, c1 : int, l2 : int, c2 : int} 85 | 86 | val location : err_stream * span -> location 87 | val position : err_stream * pos -> location 88 | 89 | (* `fmt (spec, unknown) loc` 90 | * 91 | * formats the location `loc` as a string. If `loc` is `UNKNOWN`, then the value of `unknown` 92 | * is returned. Otherwise the format commands in `spec` are used to compose the string 93 | * (in the style of C's `printf`). The supported format commands are as follows: 94 | * 95 | * %f -- the file name 96 | * %l -- the first line number 97 | * %p -- the start position of the span (line:col) 98 | * %s -- the span 99 | * %% -- the character % 100 | *) 101 | val fmt : (string * string) -> location -> string 102 | 103 | (* `locToString loc` is equivalent to `fmt ("[%f:%s] ", "") loc` *) 104 | val locToString : location -> string 105 | 106 | (* a term marked with a source-map span *) 107 | type 'a mark = {span : span, tree : 'a} 108 | 109 | end = struct 110 | 111 | structure SP = AntlrStreamPos 112 | structure FilePos = SP.FilePos 113 | structure Repair = AntlrRepair 114 | structure F = Format 115 | 116 | type pos = SP.pos 117 | type span = SP.span 118 | 119 | datatype severity = WARN | ERR 120 | 121 | type error = { 122 | kind : severity, 123 | pos : span option, 124 | msg : string 125 | } 126 | 127 | (* an error stream collects the errors and warnings generated for 128 | * a compilation unit. 129 | *) 130 | datatype err_stream = ES of { 131 | srcFile : string, 132 | sm : SP.sourcemap, (* the source map for mapping positions to *) 133 | (* source-file positions *) 134 | errors : error list ref, 135 | numErrors : int ref, 136 | numWarnings : int ref, 137 | limit : int ref (* max number of errors allowed; default is max int *) 138 | } 139 | 140 | exception ERROR 141 | 142 | (* make an error stream. *) 143 | fun mkErrStream filename = ES{ 144 | srcFile = filename, 145 | sm = SP.mkSourcemap' filename, 146 | errors = ref [], 147 | numErrors = ref 0, 148 | numWarnings = ref 0, 149 | limit = ref (valOf Int.maxInt) 150 | } 151 | 152 | fun anyErrors (ES{numErrors, ...}) = (!numErrors > 0) 153 | fun anyWarnings (ES{numWarnings, ...}) = (!numWarnings > 0) 154 | fun sourceFile (ES{srcFile, ...}) = srcFile 155 | fun sourceMap (ES{sm, ...}) = sm 156 | 157 | fun setErrorLimit (ES{limit, ...}, n) = if (n <= 0) 158 | then limit := valOf Int.maxInt 159 | else limit := n 160 | 161 | fun addErr (ES{errors, numErrors, limit, ...}, pos, msg) = 162 | if (!numErrors <= !limit) 163 | then ( 164 | numErrors := !numErrors + 1; 165 | errors := {kind=ERR, pos=pos, msg=msg} :: !errors) 166 | else raise ERROR 167 | 168 | fun addWarn (ES{errors, numWarnings, ...}, pos, msg) = ( 169 | numWarnings := !numWarnings + 1; 170 | errors := {kind=WARN, pos=pos, msg=msg} :: !errors) 171 | 172 | fun parseError tok2str es (pos, repair) = let 173 | val addToksToStr = String.concatWithMap " " (tok2str AntlrRepair.ADD) 174 | val delToksToStr = String.concatWithMap " " (tok2str AntlrRepair.DEL) 175 | val msg = (case repair 176 | of Repair.Insert toks => ["syntax error; try inserting \"", addToksToStr toks, "\""] 177 | | Repair.Delete toks => ["syntax error; try deleting \"", delToksToStr toks, "\""] 178 | | Repair.Subst{old, new} => [ 179 | "syntax error; try substituting \"", addToksToStr new, "\" for \"", 180 | delToksToStr old, "\"" 181 | ] 182 | | Repair.FailureAt tok => ["syntax error at ", tok2str AntlrRepair.DEL tok] 183 | (* end case *)) 184 | in 185 | addErr (es, SOME(pos, pos), String.concat msg) 186 | end 187 | 188 | (* add error messages to the error stream *) 189 | fun error (es, msg) = addErr (es, NONE, String.concat msg) 190 | fun errorAt (es, span, msg) = addErr (es, SOME span, String.concat msg) 191 | 192 | (* add warning messages to the error stream *) 193 | fun warning (es, msg) = addWarn (es, NONE, String.concat msg) 194 | fun warningAt (es, span, msg) = addWarn (es, SOME span, String.concat msg) 195 | 196 | (* sort a list of errors by position in the source file *) 197 | val sort = let 198 | fun gt (NONE, NONE) = false 199 | | gt (NONE, _) = true 200 | | gt (_, NONE) = false 201 | | gt (SOME(l1, r1), SOME(l2, r2)) = (case FilePos.compare(l1, l2) 202 | of LESS => false 203 | | EQUAL => (FilePos.compare(r1, r2) = GREATER) 204 | | GREATER => true 205 | (* end case *)) 206 | fun cmp (e1 : error, e2 : error) = gt(#pos e1, #pos e2) 207 | in 208 | ListMergeSort.sort cmp 209 | end 210 | 211 | (* source-code locations *) 212 | datatype location 213 | = UNKNOWN 214 | | LOC of {file : string, l1 : int, c1 : int, l2 : int, c2 : int} 215 | 216 | fun location (ES{sm, ...}, (p1, p2) : span) = 217 | if (p1 = p2) 218 | then (case SP.sourceLoc sm p1 219 | of {fileName=SOME f, lineNo, colNo} => 220 | LOC{file=f, l1=lineNo, c1=colNo, l2=lineNo, c2=colNo} 221 | | _ => UNKNOWN 222 | (* end case *)) 223 | else (case (SP.sourceLoc sm p1, SP.sourceLoc sm p2) 224 | of ( 225 | {fileName=SOME f1, lineNo=l1, colNo=c1}, 226 | {fileName=SOME f2, lineNo=l2, colNo=c2} 227 | ) => if (f1 <> f2) 228 | then LOC{file=f1, l1=l1, c1=c1, l2=l1, c2=c1} 229 | else LOC{file=f1, l1=l1, c1=c1, l2=l2, c2=c2} 230 | | _ => UNKNOWN 231 | (* end case *)) 232 | 233 | fun position (ES{sm, ...}, p : pos) = (case SP.sourceLoc sm p 234 | of {fileName=SOME f, lineNo, colNo} => 235 | LOC{file=f, l1=lineNo, c1=colNo, l2=lineNo, c2=colNo} 236 | | _ => UNKNOWN 237 | (* end case *)) 238 | 239 | local 240 | datatype fmt_items = FILE | LINE | POS | SPAN | PCT | STR of substring 241 | in 242 | 243 | (* format a location using the following formatting commands: 244 | * %f -- the file name 245 | * %l -- the first line number 246 | * %p -- the start position of the span (line:col) 247 | * %s -- the span 248 | * %% -- the character % 249 | *) 250 | fun fmt (msg, unkMsg) = let 251 | (* map msg to a list of format items *) 252 | val items = let 253 | fun split (ss, start, n, items) = (case Substring.getc ss 254 | of NONE => if (n > 0) 255 | then STR start :: items 256 | else items 257 | | SOME(#"%", ss') => let 258 | fun continue (ss'', item) = 259 | if (n > 0) 260 | then split (ss'', ss'', 0, 261 | item :: STR(Substring.slice(start, 0, SOME n)) :: items) 262 | else split (ss'', ss'', 0, item :: items) 263 | in 264 | case Substring.getc ss' 265 | of SOME(#"f", ss'') => continue (ss'', FILE) 266 | | SOME(#"l", ss'') => continue (ss'', LINE) 267 | | SOME(#"p", ss'') => continue (ss'', POS) 268 | | SOME(#"s", ss'') => continue (ss'', SPAN) 269 | | SOME(#"%", ss'') => continue (ss'', PCT) 270 | | _ => raise F.BadFormat 271 | end 272 | | SOME(_, ss') => split (ss', start, n+1, items) 273 | (* end case *)) 274 | val msg = Substring.full msg 275 | in 276 | List.rev (split (msg, msg, 0, [])) 277 | end 278 | fun fmt' UNKNOWN = unkMsg 279 | | fmt' (LOC{file, l1, l2, c1, c2}) = let 280 | val i2s = Int.toString 281 | fun lc2s (l, c, items) = i2s l :: "." :: i2s c :: items 282 | (* convert items to a string *) 283 | fun cvt (FILE, items) = file :: items 284 | | cvt (LINE, items) = Int.toString l1 :: items 285 | | cvt (POS, items) = i2s l1 :: "." :: i2s c1 :: items 286 | | cvt (SPAN, items) = if (l1 = l2) 287 | then if (c1 = c2) 288 | then lc2s(l1, c1, items) 289 | else lc2s(l1, c1, "-" :: i2s c2 :: items) 290 | else lc2s(l1, c1, "-" :: lc2s(l2, c2, items)) 291 | | cvt (PCT, items) = "%" :: items 292 | | cvt (STR ss, items) = Substring.string ss :: items 293 | in 294 | String.concat (List.foldr cvt [] items) 295 | end 296 | in 297 | fmt' 298 | end 299 | 300 | end (* local *) 301 | 302 | val locToString = fmt ("[%f:%s] ", " ") 303 | 304 | fun printError (outStrm, errStrm as ES{srcFile, ...}) = let 305 | fun pr {kind, pos, msg} = let 306 | val kind = (case kind of ERR => "Error" | Warn => "Warning") 307 | val pos = (case pos 308 | of NONE => concat["[", srcFile, "] "] 309 | | SOME span => (case location (errStrm, span) 310 | of LOC{file, l1, c1, l2, c2} => 311 | if (l1 = l2) 312 | then if (c1 = c2) 313 | then F.format "[%s:%d.%d] " [F.STR file, F.INT l1, F.INT c1] 314 | else F.format "[%s:%d.%d-%d] " [ 315 | F.STR file, F.INT l1, F.INT c1, F.INT c2 316 | ] 317 | else F.format "[%s:%d.%d-%d.%d] " [ 318 | F.STR file, F.INT l1, F.INT c1, 319 | F.INT l2, F.INT c2 320 | ] 321 | | UNKNOWN => concat["[", srcFile, "] "] 322 | (* end case *)) 323 | (* end case *)) 324 | in 325 | TextIO.output (outStrm, String.concat [pos, kind, ": ", msg, "\n"]) 326 | end 327 | in 328 | pr 329 | end 330 | 331 | fun report (outStrm, es as ES{srcFile, errors, numErrors, limit, ...}) = ( 332 | List.app (printError (outStrm, es)) (sort (!errors)); 333 | if (!numErrors > !limit) 334 | then TextIO.output (outStrm, concat[ 335 | "[", srcFile, "] Too many errors\n" 336 | ]) 337 | else ()) 338 | 339 | (* a term marked with a source-map span *) 340 | type 'a mark = {span : span, tree : 'a} 341 | 342 | end 343 | -------------------------------------------------------------------------------- /libsrc/Floats/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Floats 2 | 3 | This directory contains a representation of floating-point literals that 4 | can support IEEE features, such as -0.0, +/- infinity, and NaNs. There 5 | is also code to support generating a binary representation of a literal 6 | at various different precisions (16, 32, 64, 128, and 256 bits) according 7 | to the IEEE encoding. There is also code to support generating literals 8 | that are compatible with the LLVM IR. 9 | 10 | ### Roadmap 11 | 12 | * `README.md` -- this file 13 | * `float-constants.sml` -- floating-point literals for special constants from `math.h` 14 | * `float-lit.sml` -- the `FloatLit` structure 15 | * `float-to-bits-fn.sml` -- includes the `FloatToBitsFn` functor, as well 16 | as the `IEEE_FLOAT_PARAMS` signature its instances 17 | * `float-to-bits-sig.sml` -- the `FLOAT_TO_BITS` signature 18 | * `float-to-llvm-ir.sml` -- the `FloatToLLVMIR` structure 19 | * `float16-to-llvm.sml` -- the `Float16ToLLVM` structure 20 | * `float32-to-llvm.sml` -- the `Float32ToLLVM` structure 21 | * `sources.cm` -- CM file for compiling the code 22 | * `test32.sml` -- tests for the 32-bit encoding 23 | * `test64.sml` -- tests for the 64-bit encoding 24 | -------------------------------------------------------------------------------- /libsrc/Floats/float-constants.sml: -------------------------------------------------------------------------------- 1 | (* float-constants.sml 2 | * 3 | * Floating-point literals for the special math constants from math.h. 4 | * 5 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | structure FloatConstants : sig 31 | 32 | (* special math constants (the "M_" constants from math.h) *) 33 | val M_E : FloatLit.t (* e *) 34 | val M_LOG2E : FloatLit.t (* log2(e) *) 35 | val M_LOG10E : FloatLit.t (* log10(e) *) 36 | val M_LN2 : FloatLit.t (* ln(2) *) 37 | val M_LN10 : FloatLit.t (* ln(10) *) 38 | val M_PI : FloatLit.t (* pi *) 39 | val M_PI_2 : FloatLit.t (* pi / 2 *) 40 | val M_PI_4 : FloatLit.t (* pi / 4 *) 41 | val M_1_PI : FloatLit.t (* 1 / pi *) 42 | val M_2_PI : FloatLit.t (* 2 / pi *) 43 | val M_2_SQRTPI : FloatLit.t (* 2 / sqrt(pi) *) 44 | val M_SQRT2 : FloatLit.t (* sqrt(2) *) 45 | val M_SQRT1_2 : FloatLit.t (* 1 / sqrt(2) *) 46 | 47 | end = struct 48 | 49 | val M_E = FloatLit.fromDigits{ 50 | isNeg = false, 51 | digits = [2,7,1,8,2,8,1,8,2,8,4,5,9,0,4,5,2,3,5,3,6,0,2,8,7,4,7,1,3,5,2,6,6,2,5,0], 52 | exp = 1 53 | } 54 | val M_LOG2E = FloatLit.fromDigits{ 55 | isNeg = false, 56 | digits = [1,4,4,2,6,9,5,0,4,0,8,8,8,9,6,3,4,0,7,3,5,9,9,2,4,6,8,1,0,0,1,8,9,2,1,4], 57 | exp = 1 58 | } 59 | val M_LOG10E = FloatLit.fromDigits{ 60 | isNeg = false, 61 | digits = [0,4,3,4,2,9,4,4,8,1,9,0,3,2,5,1,8,2,7,6,5,1,1,2,8,9,1,8,9,1,6,6,0,5,0,8,2], 62 | exp = 1 63 | } 64 | val M_LN2 = FloatLit.fromDigits{ 65 | isNeg = false, 66 | digits = [6,9,3,1,4,7,1,8,0,5,5,9,9,4,5,3,0,9,4,1,7,2,3,2,1,2,1,4,5,8,1,7,6,5,6,8], 67 | exp = 0 68 | } 69 | val M_LN10 = FloatLit.fromDigits{ 70 | isNeg = false, 71 | digits = [2,3,0,2,5,8,5,0,9,2,9,9,4,0,4,5,6,8,4,0,1,7,9,9,1,4,5,4,6,8,4,3,6,4,2,1], 72 | exp = 1 73 | } 74 | val M_PI = FloatLit.fromDigits{ 75 | isNeg = false, 76 | digits = [3,1,4,1,5,9,2,6,5,3,5,8,9,7,9,3,2,3,8,4,6,2,6,4,3,3,8,3,2,7,9,5,0,2,8,8], 77 | exp = 1 78 | } 79 | val M_PI_2 = FloatLit.fromDigits{ 80 | isNeg = false, 81 | digits = [1,5,7,0,7,9,6,3,2,6,7,9,4,8,9,6,6,1,9,2,3,1,3,2,1,6,9,1,6,3,9,7,5,1,4,4], 82 | exp = 1 83 | } 84 | val M_PI_4 = FloatLit.fromDigits{ 85 | isNeg = false, 86 | digits = [7,8,5,3,9,8,1,6,3,3,9,7,4,4,8,3,0,9,6,1,5,6,6,0,8,4,5,8,1,9,8,7,5,7,2,1], 87 | exp = 0 88 | } 89 | val M_1_PI = FloatLit.fromDigits{ 90 | isNeg = false, 91 | digits = [3,1,8,3,0,9,8,8,6,1,8,3,7,9,0,6,7,1,5,3,7,7,6,7,5,2,6,7,4,5,0,2,8,7,2,4], 92 | exp = 0 93 | } 94 | val M_2_PI = FloatLit.fromDigits{ 95 | isNeg = false, 96 | digits = [6,3,6,6,1,9,7,7,2,3,6,7,5,8,1,3,4,3,0,7,5,5,3,5,0,5,3,4,9,0,0,5,7,4,4,8], 97 | exp = 0 98 | } 99 | val M_2_SQRTPI = FloatLit.fromDigits{ 100 | isNeg = false, 101 | digits = [1,1,2,8,3,7,9,1,6,7,0,9,5,5,1,2,5,7,3,8,9,6,1,5,8,9,0,3,1,2,1,5,4,5,1,7], 102 | exp = 1 103 | } 104 | val M_SQRT2 = FloatLit.fromDigits{ 105 | isNeg = false, 106 | digits = [1,4,1,4,2,1,3,5,6,2,3,7,3,0,9,5,0,4,8,8,0,1,6,8,8,7,2,4,2,0,9,6,9,8,0,8], 107 | exp = 1 108 | } 109 | val M_SQRT1_2 = FloatLit.fromDigits{ 110 | isNeg = false, 111 | digits = [7,0,7,1,0,6,7,8,1,1,8,6,5,4,7,5,2,4,4,0,0,8,4,4,3,6,2,1,0,4,8,4,9,0,3,9], 112 | exp = 0 113 | } 114 | 115 | end 116 | -------------------------------------------------------------------------------- /libsrc/Floats/float-lit.sml: -------------------------------------------------------------------------------- 1 | (* float-lit.sml 2 | * 3 | * Internal representation of floating-point literals with limited 4 | * support for arithmetic. 5 | * 6 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure FloatLit :> sig 32 | 33 | type t 34 | 35 | exception NaN 36 | 37 | (* predicates *) 38 | val isZero : t -> bool (* true for 0 or -0 *) 39 | val isNeg : t -> bool (* true for negative numbers (incl. -0) *) 40 | val isNan : t -> bool (* true for NaNs *) 41 | val isFinite : t -> bool (* true for non infinities/NaNs *) 42 | 43 | (* return the representation of +/-0.0, where zero true is -0.0 *) 44 | val zero : bool -> t 45 | 46 | (* plus and minus one *) 47 | val one : t 48 | val m_one : t 49 | 50 | (* special IEEE float values *) 51 | val nan : t (* some quiet NaN *) 52 | val posInf : t (* positive infinity *) 53 | val negInf : t (* negative infinity *) 54 | 55 | (* operations on literals as if they were reals; raise NaN if an argument is a NaN *) 56 | val lessThan : t * t -> bool (* comparison in real ordering; note that 57 | * -0.0 is not less than +0.0. 58 | *) 59 | val negate : t -> t (* negation *) 60 | val abs : t -> t (* absolute value *) 61 | 62 | (* equality, comparisons, and hashing functions *) 63 | val same : (t * t) -> bool 64 | val compare : (t * t) -> order (* not ordering on reals *) 65 | val hash : t -> word 66 | 67 | (* create a float literal from pieces: isNeg is true if the number is negative, 68 | * whole is the whole-number part, frac is the fractional part, and exp is the 69 | * exponent. This function may raise Overflow, when the exponent of the 70 | * normalized representation is too small or too large. 71 | *) 72 | val float : {isNeg : bool, whole : string, frac : string, exp : IntInf.int} -> t 73 | 74 | (* create a floating-point literal from a sign, decimal fraction, and exponent *) 75 | val fromDigits : {isNeg : bool, digits : int list, exp : IntInf.int} -> t 76 | 77 | (* create a floating-point literal from an integer *) 78 | val fromInt : IntInf.int -> t 79 | 80 | (* a concrete representation of the literal; note that +/-0 will have the 81 | * representation of digits=[], exp=0. 82 | *) 83 | datatype rep 84 | = PosInf (* positive infinity *) 85 | | NegInf (* negative infinity *) 86 | | QNaN (* some quiet NaN *) 87 | | Flt of {isNeg : bool, digits : int list, exp : IntInf.int} 88 | 89 | (* reveal the representation of the literal *) 90 | val toRep : t -> rep 91 | 92 | (* return a string representation of a literal. Note that this conversion uses "-" to 93 | * denote negative numbers (not "~"). 94 | *) 95 | val toString : t -> string 96 | 97 | (* external representation (for pickling) *) 98 | val toBytes : t -> Word8Vector.vector 99 | val fromBytes : Word8Vector.vector -> t 100 | 101 | end = struct 102 | 103 | structure SS = Substring 104 | structure W = Word 105 | structure W8V = Word8Vector 106 | 107 | (* The value {isNeg, digits=[d0, ..., dn], exp} represents the number 108 | * 109 | * [+/-] 0.d0...dn * 10^exp 110 | * 111 | * where the sign is negative if isNeg is true. We require that dn <> 0. 112 | * +/- zero is represented by the empty digit sequence. 113 | *) 114 | datatype rep 115 | = PosInf (* positive infinity *) 116 | | NegInf (* negative infinity *) 117 | | QNaN (* some quiet NaN *) 118 | | Flt of {isNeg : bool, digits : int list, exp : IntInf.int} 119 | 120 | type t = rep 121 | 122 | exception NaN 123 | 124 | fun toRep lit = lit 125 | 126 | fun isZero (Flt{digits=[], ...}) = true 127 | | isZero _ = false 128 | 129 | fun isNeg NegInf = true 130 | | isNeg (Flt{isNeg, ...}) = isNeg 131 | | isNeg _ = false 132 | 133 | fun isNan QNaN = true 134 | | isNan _ = false 135 | 136 | fun isFinite (Flt _) = true 137 | | isFinite _ = false 138 | 139 | fun zero isNeg = Flt{isNeg = isNeg, digits = [], exp = 0} 140 | 141 | val one = Flt{isNeg = false, digits = [1], exp = 1} 142 | val m_one = Flt{isNeg = true, digits = [1], exp = 1} 143 | 144 | (* special real literals *) 145 | val nan = QNaN 146 | val posInf = PosInf 147 | val negInf = NegInf 148 | 149 | fun lessThan (QNaN, _) = raise NaN 150 | | lessThan (_, QNaN) = raise NaN 151 | | lessThan (_, NegInf) = false 152 | | lessThan (NegInf, _) = true 153 | | lessThan (PosInf, _) = false 154 | | lessThan (_, PosInf) = false 155 | | lessThan (Flt{digits=[], ...}, Flt{digits=[], ...}) = false 156 | | lessThan (Flt{isNeg=true, ...}, Flt{isNeg=false, ...}) = true 157 | | lessThan (Flt{isNeg=false, ...}, Flt{isNeg=true, ...}) = false 158 | | lessThan (Flt{isNeg, digits=d1, exp=e1}, Flt{digits=d2, exp=e2, ...}) = 159 | (* both have same sign *) 160 | if (e1 < e2) then not isNeg 161 | else if (e2 < e1) then isNeg 162 | else (case List.collate Int.compare (d1, d2) 163 | of LESS => not isNeg 164 | | EQUAL => false 165 | | GREATER => isNeg 166 | (* end case *)) 167 | 168 | (* negate a real literal *) 169 | fun negate PosInf = NegInf 170 | | negate NegInf = PosInf 171 | | negate QNaN = raise NaN 172 | | negate (Flt{isNeg, digits, exp}) = 173 | Flt{isNeg = not isNeg, digits = digits, exp = exp} 174 | 175 | (* return the absolute value of a literal *) 176 | fun abs PosInf = PosInf 177 | | abs NegInf = PosInf 178 | | abs QNaN = raise NaN 179 | | abs (Flt{digits, exp, ...}) = Flt{isNeg=false, digits=digits, exp=exp} 180 | 181 | (* equality, comparisons, and hashing functions *) 182 | fun same (NegInf, NegInf) = true 183 | | same (PosInf, PosInf) = true 184 | | same (QNaN, QNaN) = true 185 | | same (Flt f1, Flt f2) = 186 | (#isNeg f1 = #isNeg f2) andalso (#exp f1 = #exp f2) 187 | andalso (#digits f1 = #digits f2) 188 | | same _ = false 189 | 190 | fun compare (NegInf, NegInf) = EQUAL 191 | | compare (NegInf, _) = LESS 192 | | compare (_, NegInf) = GREATER 193 | | compare (PosInf, PosInf) = EQUAL 194 | | compare (PosInf, _) = LESS 195 | | compare (_, PosInf) = GREATER 196 | | compare (QNaN, QNaN) = EQUAL 197 | | compare (QNaN, _) = LESS 198 | | compare (_, QNaN) = GREATER 199 | | compare (Flt f1, Flt f2) = (case (#isNeg f1, #isNeg f2) 200 | of (false, true) => GREATER 201 | | (true, false) => LESS 202 | | _ => (case IntInf.compare(#exp f1, #exp f2) 203 | of EQUAL => let 204 | fun cmp ([], []) = EQUAL 205 | | cmp ([], _) = LESS 206 | | cmp (_, []) = GREATER 207 | | cmp (d1::r1, d2::r2) = (case Int.compare(d1, d2) 208 | of EQUAL => cmp(r1, r2) 209 | | order => order 210 | (* end case *)) 211 | in 212 | cmp (#digits f1, #digits f2) 213 | end 214 | | order => order 215 | (* end case *)) 216 | (* end case *)) 217 | 218 | fun hash PosInf = 0w1 219 | | hash NegInf = 0w3 220 | | hash QNaN = 0w5 221 | | hash (Flt{isNeg, digits, exp}) = let 222 | fun hashDigits ([], h, _) = h 223 | | hashDigits (d::r, h, i) = 224 | hashDigits (r, W.<<(W.fromInt d, i+0w4), W.andb(i+0w1, 0wxf)) 225 | in 226 | hashDigits(digits, W.fromLargeInt exp, 0w0) 227 | end 228 | 229 | fun float {isNeg, whole, frac, exp} = let 230 | fun cvtDigit (c, l) = (Char.ord c - Char.ord #"0") :: l 231 | fun isZero #"0" = true | isZero _ = false 232 | (* whole digits with leading zeros removed *) 233 | val whole = SS.dropl isZero (SS.full whole) 234 | (* fractional digits with trailing zeros removed *) 235 | val frac = SS.dropr isZero (SS.full frac) 236 | (* normalize by stripping leading zero digits *) 237 | fun normalize {isNeg, digits=[], exp} = zero isNeg 238 | | normalize {isNeg, digits=0::r, exp} = 239 | normalize {isNeg=isNeg, digits=r, exp=exp-1} 240 | | normalize flt = Flt flt 241 | in 242 | case SS.foldr cvtDigit (SS.foldr cvtDigit [] frac) whole 243 | of [] => zero isNeg 244 | | digits => normalize { 245 | isNeg = isNeg, 246 | digits = digits, 247 | exp = exp + IntInf.fromInt(SS.size whole) 248 | } 249 | (* end case *) 250 | end 251 | 252 | (* helper function to strip trailing zeros from a list of digits *) 253 | fun stripZeros {isNeg, digits, exp} = let 254 | fun strip [] = [] 255 | | strip (0::ds) = (case strip ds 256 | of [] => [] 257 | | ds => 0::ds 258 | (* end case *)) 259 | | strip (d::ds) = d :: strip ds 260 | in 261 | case strip digits 262 | of [] => zero isNeg 263 | | digits => Flt{isNeg=isNeg, digits=digits, exp=exp} 264 | (* end case *) 265 | end 266 | 267 | (* create a floating-point literal from a sign, decimal fraction, and exponent *) 268 | fun fromDigits arg = let 269 | (* normalize by stripping leading zero digits *) 270 | fun normalize {isNeg, digits=[], exp} = zero isNeg 271 | | normalize {isNeg, digits=0::r, exp} = 272 | normalize {isNeg=isNeg, digits=r, exp=exp-1} 273 | | normalize arg = stripZeros arg 274 | in 275 | normalize arg 276 | end 277 | 278 | fun fromInt 0 = zero false 279 | | fromInt n = let 280 | val (isNeg, n) = if (n < 0) then (true, ~n) else (false, n) 281 | fun toDigits (n, ds) = if n < 10 282 | then IntInf.toInt n :: ds 283 | else let 284 | val (q, r) = IntInf.quotRem(n, 10) 285 | in 286 | toDigits(q, IntInf.toInt r :: ds) 287 | end 288 | val digits = toDigits(n, []) 289 | in 290 | stripZeros { 291 | isNeg = isNeg, 292 | digits = digits, 293 | exp = IntInf.fromInt(List.length digits) 294 | } 295 | end 296 | 297 | fun toString PosInf = "+inf" 298 | | toString NegInf = "-inf" 299 | | toString QNaN = "nan" 300 | | toString (Flt{isNeg, digits=[0], ...}) = if isNeg then "-0.0" else "0.0" 301 | | toString (Flt{isNeg, digits, exp}) = let 302 | val s = if isNeg then "-0." else "0." 303 | val e = if exp < 0 304 | then ["e-", IntInf.toString(~exp)] 305 | else ["e", IntInf.toString exp] 306 | in 307 | concat(s :: List.foldr (fn (d, ds) => Int.toString d :: ds) e digits) 308 | end 309 | 310 | (***** external representation (for pickling) ***** 311 | * 312 | * The representation we use is a sequence of bytes: 313 | * 314 | * [sign, d0, ..., dn, exp0, ..., exp3] 315 | * 316 | * where 317 | * sign == 0 or 1 318 | * di == ith digit 319 | * expi == ith byte of exponent (exp0 is lsb, exp3 is msb). 320 | * 321 | * we encode Infs and NaNs using the sign byte: 322 | * 323 | * 2 == PosInf 324 | * 3 == NegInf 325 | * 4 == QNaN 326 | * 327 | * NOTE: we could pack the sign and digits into 4-bit nibbles, but we are keeping 328 | * things simple for now. 329 | *) 330 | 331 | fun toBytes PosInf = Word8Vector.fromList [0w2] 332 | | toBytes NegInf = Word8Vector.fromList [0w3] 333 | | toBytes QNaN = Word8Vector.fromList [0w4] 334 | | toBytes (Flt{isNeg, digits, exp}) = let 335 | val sign = if isNeg then 0w1 else 0w0 336 | val digits = List.map Word8.fromInt digits 337 | val exp' = W.fromLargeInt exp 338 | fun byte i = Word8.fromLargeWord(W.toLargeWord((W.>>(exp', 0w8*i)))) 339 | val exp = [byte 0w3, byte 0w2, byte 0w1, byte 0w0] 340 | in 341 | Word8Vector.fromList(sign :: (digits @ exp)) 342 | end 343 | 344 | fun fromBytes v = let 345 | fun error () = raise Fail "Bogus real-literal pickle" 346 | val len = W8V.length v 347 | in 348 | if (len = 1) 349 | then (case W8V.sub(v, 0) (* special real value *) 350 | of 0w2 => PosInf 351 | | 0w3 => NegInf 352 | | 0w4 => QNaN 353 | | _ => error() 354 | (* end case *)) 355 | else let 356 | val ndigits = W8V.length v - 5 357 | val _ = if (ndigits < 0) then error() else () 358 | val isNeg = (case W8V.sub(v, 0) 359 | of 0w0 => false 360 | | 0w1 => true 361 | | _ => error() 362 | (* end case *)) 363 | fun digit i = let val d = Word8.toInt(W8V.sub(v, i+1)) 364 | in 365 | if (d < 10) then d else error() 366 | end 367 | fun byte i = W.<<( 368 | W.fromLargeWord(Word8.toLargeWord(W8V.sub(v, ndigits+1+i))), 369 | W.fromInt(8*(3-i))) 370 | val exp = W.toLargeIntX(W.orb(byte 3, W.orb(byte 2, W.orb(byte 1, byte 0)))) 371 | in 372 | Flt{isNeg = isNeg, digits = List.tabulate(ndigits, digit), exp = exp} 373 | end 374 | end 375 | 376 | end 377 | 378 | -------------------------------------------------------------------------------- /libsrc/Floats/float-to-bits-fn.sml: -------------------------------------------------------------------------------- 1 | (* float-to-bits-fn.sml 2 | * 3 | * This code was derived from the RealConst functor in the SML/NJ sources 4 | * (base/compiler/MiscUtil/bignums/realconst.sml). 5 | * 6 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | (* the parameters for an IEEE floating-point representation. Consider a binary 32 | * floating point number 33 | * 34 | * r = (-1)^s * 2^{exp} * b_0 . b_1 b_2 ... b_{p-1} 35 | * 36 | * where 's' is the sign bit, 'exp' is the exponent, and 'p' is the precision of the 37 | * significand (aka mantissa). The IEEE encoding represents this number as follows: 38 | * 39 | * [s | E | b_1 b_2 ... b_{p-1} ] 40 | * 41 | * where 42 | * - biased exponent E = e + bias (w bits) 43 | * - significand T = b_1 b_2 b_3 ... b_{p-1} 44 | * - the bias = 2^{w-1} - 1. 45 | * 46 | * The width of the representation is w+p. 47 | * 48 | * For normal numbers, 'b_0' is assumed to be 1 and the exponent 'e' range from 1-bias 49 | * to bias. 50 | * 51 | * NaNs and Infs are encoded with an exponent of 2^w - 1 (i.e., all 1s). Specifically, 52 | * we have the following encodings: 53 | * 54 | * +inf [ 0 | 1{w} | 0{p-1} ] 55 | * -inf [ 1 | 1{w} | 0{p-1} ] 56 | * Quiet NaN [ s | 1{w} | 1 b_2 ... b_{p-1} ] 57 | * Signaling NaN [ s | 1{w} | 0 b_2 ... b_{p-1} ] -- at least on of the b_i must be 1 58 | * 59 | * Subnormal numbers are encoded with an exponent of 0 and a non-zero mantissa. 60 | * 61 | * r = (-1)^s * 2^{-bias+1} * 0 . b_1 b_2 ... b_{p-1} 62 | *) 63 | signature IEEE_FLOAT_PARAMS = 64 | sig 65 | 66 | (* the total number of bits in the representation; this value should be 67 | * a multiple of 8. 68 | *) 69 | val width : int 70 | 71 | (* the number of bits in the significand; this value is one larger than 72 | * the width of the mantissa field, since it includes the redundant bit. 73 | *) 74 | val significant : int 75 | 76 | (* the exponent bias *) 77 | val bias : int 78 | 79 | end 80 | 81 | functor FloatToBitsFn (FP : IEEE_FLOAT_PARAMS) : FLOAT_TO_BITS = 82 | struct 83 | 84 | structure W = Word 85 | structure W8 = Word8 86 | structure W8A = Word8Array 87 | 88 | (* convert a Word.word to a Word8.word *) 89 | fun w2b w = W8.fromLargeWord(W.toLargeWord w) 90 | fun b2w b = W.fromLargeWord(W8.toLargeWord b) 91 | 92 | (* representation width of the literal type *) 93 | val width = FP.width 94 | 95 | (* number of bits in exponent *) 96 | val expWidth = FP.width - FP.significant 97 | 98 | (* unbiased min and max exponents *) 99 | val maxExp = Word.toIntX(Word.<<(0w1, W.fromInt(expWidth-1)) - 0w1) 100 | val minExp = 1 - maxExp 101 | 102 | val bias = FP.bias (* biased exponents range from 1<=exp 0) 107 | then raise Fail "FloatToBitsFn: invalid width" 108 | else (); 109 | if (FP.significant < 11) orelse (width-5 < FP.significant) 110 | then raise Fail "FloatToBitsFn: invalid significant" 111 | else (); 112 | if (FP.bias <> maxExp) 113 | then raise Fail "FloatToBitsFn: invalid bias" 114 | else ()) 115 | 116 | (* number of bytes needed to represent a float *) 117 | val numBytes = FP.width div 8 118 | 119 | (* number of bytes in the representation that contain at least one bit 120 | * of the mantissa. Note that `significant` is the width of mantissa bits + 1. 121 | *) 122 | val numMantBytes = (FP.significant + 6) div 8 123 | 124 | (* number of bytes in the representation that contain at least one bit 125 | * of the exponent. 126 | *) 127 | val numExpBytes = (expWidth + 8) div 8 128 | 129 | (* index of the first mantissa byte *) 130 | val firstMantByte = numBytes - numMantBytes 131 | 132 | (* shift amount needed to align exponent with its position in the target. E.g., 133 | * the IEEE 32-bit exponent is 11 bits (bits 1--11), so we need to left shift 134 | * four to get it aligned. 135 | *) 136 | val expShift = Word.fromInt(8 * numExpBytes - (expWidth + 1)) 137 | 138 | (* bit layout for mantissa; each element has the byte index, the start bit 139 | * (numbered from the MSB to LSB), and the width of the bits for that byte. 140 | * For example, the IEEE 32-bit float, which has a 24 bit significand (23 141 | * bits + 1), has the layout 142 | * {byte = 1, start = 1, width = 7}, 143 | * {byte = 2, start = 8, width = 8}, 144 | * {byte = 3, start = 16, width = 8} 145 | *) 146 | val fracLayout : {byte : int, start : int, width : int} list = let 147 | val firstByte = numBytes - numMantBytes 148 | val firstBitWidth = 8 - ((expWidth + 1) mod 8) 149 | fun layout 0 = {byte = firstByte, start = 1, width = firstBitWidth} 150 | | layout i = { 151 | byte = firstByte + i, 152 | start = firstBitWidth + 1 + (i-1) * 8, 153 | width = 8 154 | } 155 | in 156 | List.tabulate (numMantBytes, layout) 157 | end 158 | 159 | (* Use more than the required precision, then round at the end. We need bits 160 | * for the mantissa, plus bits for the bias, plus bits for one additional decimal 161 | * digit. 162 | *) 163 | val precision = FP.significant + expWidth + 4 164 | 165 | (* the number of bits needed to represent a positive IntInf.int *) 166 | fun numBitsForInt n = IntInf.log2 n + 1 167 | 168 | (* A float is a WHOLE "fraction" and an exponent base TWO. *) 169 | type float = {frac : IntInf.int, exp : int} 170 | 171 | (* round a float to n significant binary digits *) 172 | fun round (float as {frac, exp}, n) = let 173 | val shift = numBitsForInt frac + 1 - n 174 | in 175 | if shift <= 0 176 | then float 177 | else { 178 | frac = if (IntInf.andb(frac, IntInf.<<(1, W.fromInt(shift-1))) = 0) 179 | then IntInf.~>>(frac, W.fromInt shift) 180 | else IntInf.~>>(frac, W.fromInt shift) + 1, 181 | exp = exp + shift 182 | } 183 | end 184 | 185 | (* float values ten and one tenth, to the correct precision. *) 186 | val ten : float = {frac = 5, exp = 1} 187 | val tenth : float = let 188 | fun mk 1 = {frac = 1, exp = ~4} 189 | | mk n = let 190 | val {frac, exp} = mk (n-1) 191 | val tenthBit = (case n mod 4 192 | of 0 => 0 193 | | 1 => 1 194 | | 2 => 1 195 | | _ => 0 196 | (* end case *)) 197 | val f = 2 * frac + tenthBit 198 | val e = exp - 1 199 | in 200 | {frac = f, exp = e} 201 | end 202 | in 203 | round (mk (precision+1), precision) 204 | end 205 | 206 | (* Multiplies two floats together to the correct precision *) 207 | fun mult ({frac=f1, exp=e1} : float, {frac=f2, exp=e2}) = 208 | round ({frac = f1 * f2, exp = e1 + e2}, precision) 209 | 210 | local 211 | (* a cache of powers of 10 *) 212 | datatype cache = C of float option array ref 213 | fun newCache f0 = let 214 | val arr = Array.array(16, NONE) 215 | in 216 | Array.update (arr, 0, SOME f0); 217 | C(ref arr) 218 | end 219 | fun grow (C(cache as ref arr), sz) = let 220 | val sz = Int.max(sz+1, 2*Array.length arr) 221 | val newArr = Array.array(sz, NONE) 222 | in 223 | Array.appi (fn (i, f) => Array.update(newArr, i, f)) arr; 224 | cache := newArr 225 | end 226 | fun access (cache as C(ref arr), n) = 227 | if (n < Array.length arr) 228 | then let 229 | fun get i = (case Array.sub(arr, i) 230 | of NONE => let 231 | val prev = get (i-1) 232 | val flt = mult(prev, prev) 233 | in 234 | Array.update(arr, n, SOME flt); 235 | flt 236 | end 237 | | SOME flt => flt 238 | (* end case *)) 239 | in 240 | get n 241 | end 242 | else (grow (cache, n); access (cache, n)) 243 | val pos10 = newCache ten (* 10^2^n *) 244 | val neg10 = newCache tenth (* 10^-2^n *) 245 | (* FIXME: we should check for too large exponents to avoid having the table blow up on bad inputs *) 246 | fun pow10_2 0 = {frac = 1, exp = 0} 247 | | pow10_2 n = if (n > 0) then access(pos10, n - 1) else access(neg10, ~n - 1) 248 | in 249 | fun raiseToPower (f, 0) = f 250 | | raiseToPower (f, e) = let 251 | val (sign, e) = if (e < 0) then (~1, ~e) else (1, e) 252 | fun power (f, p) = mult (f, pow10_2 (sign * p)) 253 | fun raisep (f, 0w0, _) = f 254 | | raisep (f, e, p) = 255 | if W.andb(e, 0w1) = 0w1 256 | then raisep (power(f, p), W.>>(e, 0w1), p+1) 257 | else raisep(f, W.>>(e, 0w1), p+1) 258 | in 259 | raisep (f, W.fromInt(abs e), 1) 260 | end 261 | end (* local *) 262 | 263 | (* Take an IntInf.int representing the fractional part of a float and return a 264 | * function that will generate the mantissa bits. The function is called with 265 | * two integers (start,width), and returns a byte representing the bits of frac 266 | * from start to start+width-1, where bits are numbered from MSB to LSB. We 267 | * assume that `0 < frac`, `0 <= start`, and `0 < width <= 8`. 268 | *) 269 | fun makebits 0 = (fn _ => 0w0) 270 | | makebits frac = let 271 | (* the number of bits needed to represent frac *) 272 | val s = numBitsForInt frac 273 | (* mask for high bit of frac *) 274 | val highBit = IntInf.<<(1, W.fromInt(s-1)) 275 | (* loop to generate bits: `i` is loop bound (starts at width), `fracBit` is 276 | * is the bit mask for testing bits in frac, `bit` is the corresponding bit 277 | * being tested, and `bits` is the accumulated bit values. 278 | *) 279 | fun getBits (i, fracBit, bit, bits) = 280 | if (0 < i) andalso (fracBit > 0) 281 | then let 282 | val fracBit' = IntInf.~>>(fracBit, 0w1) 283 | val bit' = W.>>(bit, 0w1) 284 | in 285 | if (IntInf.andb(frac, fracBit) = 0) 286 | then getBits (i-1, fracBit', bit', bits) 287 | else getBits (i-1, fracBit', bit', W.orb(bits, bit)) 288 | end 289 | else w2b bits 290 | fun mk (start, width) = let 291 | val fracBit = IntInf.~>>(highBit, W.fromInt start) 292 | val bit = W.<<(0w1, W.fromInt(width-1)) 293 | in 294 | getBits (width, fracBit, bit, 0w0) 295 | end 296 | in 297 | mk 298 | end 299 | 300 | (* allocate a byte array and set the sign and exponent fields *) 301 | fun mkSignAndExp (isNeg, exp) = let 302 | (* allocate and initialize space for the result *) 303 | val bytes = W8A.array(numBytes, 0w0) 304 | (* set the modify the i'th byte by or'ing in b *) 305 | fun orb (i, b) = W8A.update(bytes, i, W8.orb(W8A.sub(bytes, i), b)) 306 | (* start by setting the sign bit *) 307 | val _ = if isNeg then W8A.update(bytes, 0, 0wx80) else (); 308 | (* process the exponent *) 309 | val alignedExp = Word.<<(exp, expShift) 310 | fun doExpBytes i = if (i < numExpBytes) 311 | then ( 312 | orb (i, w2b (Word.>>(alignedExp, 0w8*Word.fromInt(numExpBytes-i-1)))); 313 | doExpBytes (i+1)) 314 | else () 315 | in 316 | doExpBytes 0; 317 | bytes 318 | end 319 | 320 | (* build the byte-vector representation, where isNeg denotes the sign, exp is the word 321 | * representation of the biased exponent, and frac is the IntInf.int representation of 322 | * the mantissa. 323 | *) 324 | fun pack (isNeg, exp, frac : IntInf.int) = let 325 | (* allocate and initialize space for the result *) 326 | val bytes = mkSignAndExp (isNeg, exp) 327 | (* set the modify the i'th byte by or'ing in b *) 328 | fun orb (i, b) = W8A.update(bytes, i, W8.orb(W8A.sub(bytes, i), b)) 329 | (* process the mantissa *) 330 | val makebits = makebits frac 331 | val _ = List.app 332 | (fn {byte, start, width} => orb (byte, makebits (start, width))) 333 | fracLayout 334 | in 335 | (* return the immutable vector representation *) 336 | W8A.toVector bytes 337 | end 338 | 339 | (* build the byte-vector representation for a non-normal representation (i.e., sub-normal 340 | * numbers, infinities, or NaNs), where isNeg denotes the sign, exp is the special 341 | * exponent value, and frac is the IntInf.int representation of the mantissa. 342 | *) 343 | fun packSpecial (isNeg, exp, frac : IntInf.int) = let 344 | (* allocate and initialize space for the result *) 345 | val bytes = mkSignAndExp (isNeg, exp) 346 | (* set the modify the i'th byte by or'ing in b *) 347 | fun orb (i, b) = W8A.update(bytes, i, W8.orb(W8A.sub(bytes, i), b)) 348 | (* fill in the mantissa bits *) 349 | fun lp (mant, ix) = if (mant > 0) 350 | then ( 351 | orb (ix, W8.fromLargeInt mant); (* grab low 8 bits of mantissa *) 352 | lp (IntInf.~>>(mant, 0w8), ix - 1)) 353 | else () 354 | in 355 | lp (frac, numBytes-1); 356 | (* return the immutable vector representation *) 357 | W8A.toVector bytes 358 | end 359 | 360 | val specialExp = Word.<<(0w1, Word.fromInt expWidth) - 0w1 361 | 362 | fun zero isNeg = pack(isNeg, 0w0, 0) 363 | val posInf = packSpecial (false, specialExp, 0) 364 | val negInf = packSpecial (true, specialExp, 0) 365 | val quietNaN = packSpecial (false, specialExp, 1) (* quiet NaN with 0 payload *) 366 | 367 | fun classify lit = (case FloatLit.toRep lit 368 | of FloatLit.PosInf => IEEEReal.INF 369 | | FloatLit.NegInf => IEEEReal.INF 370 | | FloatLit.QNaN => IEEEReal.NAN 371 | | FloatLit.Flt{isNeg, digits=[], exp} => IEEEReal.ZERO 372 | | FloatLit.Flt{isNeg, digits, exp} => let 373 | (* convert the digits to a IntInf.int and adjust the exponent *) 374 | val (frac_10, exp_10) = let 375 | fun doDigit (d, (m, e)) = (IntInf.fromInt d + 10*m, e-1) 376 | val (frac, exp) = List.foldl doDigit (0, exp) digits 377 | in 378 | (frac, IntInf.toInt exp) 379 | end 380 | (* convert to base 2 *) 381 | val flt = raiseToPower (round({frac=frac_10, exp=0}, precision), exp_10) 382 | val {frac, exp} = round(flt, FP.significant+1) 383 | (* adjust exp for size of fraction *) 384 | val exp = exp + numBitsForInt frac - 1 385 | in 386 | if (exp < minExp) 387 | then let 388 | val diff = Word.fromInt(minExp - exp) 389 | val frac = IntInf.~>>(frac, diff) 390 | in 391 | if frac > 0 392 | then IEEEReal.SUBNORMAL 393 | else IEEEReal.ZERO 394 | end 395 | else if (maxExp < exp) 396 | then IEEEReal.INF 397 | else IEEEReal.NORMAL 398 | end 399 | (* end case *)) 400 | 401 | fun toBits lit = (case FloatLit.toRep lit 402 | of FloatLit.PosInf => (posInf, IEEEReal.INF) 403 | | FloatLit.NegInf => (negInf, IEEEReal.INF) 404 | | FloatLit.QNaN => (quietNaN, IEEEReal.NAN) 405 | | FloatLit.Flt{isNeg, digits=[], exp} => (zero isNeg, IEEEReal.ZERO) 406 | | FloatLit.Flt{isNeg, digits, exp} => let 407 | (* convert the digits to a IntInf.int and adjust the exponent *) 408 | val (frac_10, exp_10) = let 409 | fun doDigit (d, (m, e)) = (IntInf.fromInt d + 10*m, e-1) 410 | val (frac, exp) = List.foldl doDigit (0, exp) digits 411 | in 412 | (frac, IntInf.toInt exp) 413 | end 414 | (* convert to base 2 *) 415 | val flt = raiseToPower (round({frac=frac_10, exp=0}, precision), exp_10) 416 | val {frac, exp} = round(flt, FP.significant+1) 417 | (* adjust exp for size of fraction *) 418 | val exp = exp + numBitsForInt frac - 1 419 | in 420 | if (exp < minExp) 421 | then let 422 | val diff = Word.fromInt(minExp - exp) 423 | val frac = IntInf.~>>(frac, diff) 424 | in 425 | if frac > 0 426 | then (packSpecial (isNeg, 0w0, frac), IEEEReal.SUBNORMAL) 427 | else (zero isNeg, IEEEReal.ZERO) 428 | end 429 | else if (maxExp < exp) 430 | then raise Overflow 431 | else (pack (isNeg, W.fromInt(exp + maxExp), frac), IEEEReal.NORMAL) 432 | end 433 | (* end case *)) 434 | 435 | (* TODO: 436 | (* make a FloatLit.t value from the sign, biased exponent, and mantissa *) 437 | fun mkLiteral (isNeg, exp, mant) = 438 | in 439 | if (exp = 0w0) andalso (mant = 0) 440 | then if (mant = 0) 441 | then SOME FloatLit.zero isNeg 442 | else (* subnormal number *) 443 | else if (exp = specialExp) 444 | then if (mant <> 0) 445 | then SOME FloatLit.nan (* it may be a different NaN *) 446 | else if isNeg 447 | then SOME FloatLit.negInf 448 | else SOME FloatLit.posInf 449 | else let 450 | (* unbias exponent *) 451 | val exp = (W.toInt exp) - maxExp 452 | (* add implicit leading 1 digit to mantissa *) 453 | val mant = mant + IntInf.<<(1, W.fromInt(FP.significant)) 454 | in 455 | (* see http://sandbox.mc.edu/~bennet/cs110/flt/ftod.html *) 456 | (* normal float *) 457 | end 458 | end 459 | 460 | fun fromBits v = if (W8V.length v <> numBytes) 461 | then NONE 462 | else let 463 | (* get the sign bit *) 464 | val isNeg = (Word8.andb(0wx80, W8V.sub(v, 0)) <> 0) 465 | (* extract the biased exponent *) 466 | val exp = let 467 | fun lp (i, acc) = 468 | if (i < numExpBytes) 469 | then lp (i+1, W.orb(W.<<(acc, 0w8), W8V.sub(v, i))) 470 | else acc 471 | in 472 | lp (1, Word.andb(W8V.sub(v, 0), 0wxFF)) 473 | end 474 | (* extract the mantissa as an IntInf.int *) 475 | val mant = let 476 | fun f ({byte, start, width}, acc) = let 477 | (* get the `width` low-order bits from the byte *) 478 | val b = W.andb(W.>>(0wxff, W.fromInt(8-width)), b2w (W8V.sub(v, byte))) 479 | in 480 | IntInf.<<(acc, IntInf.fromInt width) + IntInf.fromInt(W.toInt b) 481 | end 482 | in 483 | List.foldl f 0 fracLayout 484 | end 485 | in 486 | mkLiteral (isNeg, exp, mant) 487 | end 488 | 489 | (* literal representation of minimum positive normal float value *) 490 | val minNormal = mkLiteral (false, 0w1, 0) 491 | 492 | (* literal representation of minimum positive sub-normal float value *) 493 | val minNormal = mkLiteral (false, 0w0, 1) 494 | 495 | (* literal representation of maximum positive finite float value *) 496 | val maxFinite = 497 | fromBits (false, W.fromInt maxExp, IntInf.<<(1, W.fromInt FP.significant - 0w1) - 1) 498 | *) 499 | 500 | end; 501 | 502 | structure IEEEFloat16Params : IEEE_FLOAT_PARAMS = 503 | struct 504 | val width = 16 505 | val significant = 11 506 | val bias = 15 507 | end; 508 | 509 | structure IEEEFloat32Params : IEEE_FLOAT_PARAMS = 510 | struct 511 | val width = 32 512 | val significant = 24 513 | val bias = 127 514 | end; 515 | 516 | structure IEEEFloat64Params : IEEE_FLOAT_PARAMS = 517 | struct 518 | val width = 64 519 | val significant = 53 520 | val bias = 1023 521 | end; 522 | 523 | structure IEEEFloat128Params : IEEE_FLOAT_PARAMS = 524 | struct 525 | val width = 128 526 | val significant = 113 527 | val bias = 16383 528 | end; 529 | 530 | structure IEEEFloat256Params : IEEE_FLOAT_PARAMS = 531 | struct 532 | val width = 256 533 | val significant = 237 534 | val bias = 262143 535 | end; 536 | -------------------------------------------------------------------------------- /libsrc/Floats/float-to-bits-sig.sml: -------------------------------------------------------------------------------- 1 | (* float-to-bits-sig.sml 2 | * 3 | * This code was derived from the RealConst functor in the SML/NJ sources 4 | * (base/compiler/MiscUtil/bignums/realconst.sml). 5 | * 6 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | signature FLOAT_TO_BITS = 32 | sig 33 | 34 | (* the number of bits in the representation *) 35 | val width : int 36 | 37 | (* classify a floating-point literal based on its representation as an IEEE float 38 | * of the given precision. This function will return ZERO on numbers that are too 39 | * small to represent and will return INF for numbers that are too large. In these 40 | * cases, one can use FloatLit.isZero and FloatLit.isFinite functions to further 41 | * classify the number. 42 | *) 43 | val classify : FloatLit.t -> IEEEReal.float_class 44 | 45 | (* convert a floating-point literal to its IEEE binary representation; we also 46 | * return the IEEE classification of the value. The resulting vector is in 47 | * big-endian layout (i.e., the sign bit will be the MSB of the first byte). 48 | * This function raises the Overflow exception when the literal is too large 49 | * to represent. 50 | *) 51 | val toBits : FloatLit.t -> Word8Vector.vector * IEEEReal.float_class 52 | 53 | (* 54 | val fromBits : Word8Vector.vector -> FloatLit.t 55 | *) 56 | 57 | val zero : bool -> Word8Vector.vector 58 | val negInf : Word8Vector.vector 59 | val posInf : Word8Vector.vector 60 | val quietNaN : Word8Vector.vector 61 | 62 | end 63 | -------------------------------------------------------------------------------- /libsrc/Floats/float-to-llvm-ir.sml: -------------------------------------------------------------------------------- 1 | (* float-to-llvm-ir.sml 2 | * 3 | * This module supports converting float litearals to hexidecimal 4 | * strings that are suitable for use as constants in an LLVM 5 | * assembler file. 6 | * 7 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 8 | * 9 | * Permission is hereby granted, free of charge, to any person obtaining a copy 10 | * of this software and associated documentation files (the "Software"), to deal 11 | * in the Software without restriction, including without limitation the rights 12 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 13 | * copies of the Software, and to permit persons to whom the Software is 14 | * furnished to do so, subject to the following conditions: 15 | * 16 | * The above copyright notice and this permission notice shall be included in all 17 | * copies or substantial portions of the Software. 18 | * 19 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 20 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 22 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 23 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 24 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 25 | * SOFTWARE. 26 | * 27 | * This code is part of the SML Compiler Utilities, which can be found at 28 | * 29 | * https://github.com/JohnReppy/sml-compiler-utils 30 | *) 31 | 32 | structure FloatToLLVMIR : sig 33 | 34 | exception InvalidWidth 35 | 36 | (* convert a float literal of the specified width to an LLVM float constant 37 | * (represented as a string). Raises InvalidWidth if the width is one of 38 | * the supported formats (16, 32, 64, or 128). 39 | *) 40 | val toString : FloatLit.t * int -> string 41 | 42 | end = struct 43 | 44 | structure F16ToBits = Float16ToLLVM 45 | structure F32ToBits = Float32ToLLVM 46 | structure F64ToBits = FloatToBitsFn (IEEEFloat64Params) 47 | structure F128ToBits = FloatToBitsFn (IEEEFloat128Params) 48 | 49 | exception InvalidWidth 50 | 51 | val byte2s = (StringCvt.padLeft #"0" 2) o Word8.fmt StringCvt.HEX 52 | 53 | fun fmt (prefix, (bytes, _)) = let 54 | fun fmtByte (b, digits) = byte2s b :: digits 55 | in 56 | String.concat (prefix :: Word8Vector.foldr fmtByte [] bytes) 57 | end 58 | 59 | fun toString (lit, 16) = fmt ("0xH", F16ToBits.toBits lit) 60 | | toString (lit, 32) = fmt ("0x", F32ToBits.toBits lit) 61 | | toString (lit, 64) = fmt ("0x", F64ToBits.toBits lit) 62 | | toString (lit, 128) = fmt ("0xL", F128ToBits.toBits lit) 63 | | toString _ = raise InvalidWidth 64 | 65 | end 66 | -------------------------------------------------------------------------------- /libsrc/Floats/float16-to-llvm.sml: -------------------------------------------------------------------------------- 1 | (* float16-to-llvm-fn.sml 2 | * 3 | * This module supports converting 16-bit float literals to 8-byte bit 4 | * strings suitable for emitting into an LLVM assembler file. 5 | * 6 | * The LLVM assembler expects floating-point literals to be either decimal 7 | * literals that are exactly representable in floating-point, or hexidecimal 8 | * bit strings. For 16, 32, and 64-bit floats, the bit strings must be 9 | * written as 16-digit hexidecimal numbers. This requirement means that 10 | * the bit representation of the exponent and mantissa must be converted 11 | * to double-precision format. 12 | * 13 | * This code is based on code contributed by Kavon Farvardin. 14 | * 15 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 16 | * 17 | * Permission is hereby granted, free of charge, to any person obtaining a copy 18 | * of this software and associated documentation files (the "Software"), to deal 19 | * in the Software without restriction, including without limitation the rights 20 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 21 | * copies of the Software, and to permit persons to whom the Software is 22 | * furnished to do so, subject to the following conditions: 23 | * 24 | * The above copyright notice and this permission notice shall be included in all 25 | * copies or substantial portions of the Software. 26 | * 27 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 28 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 29 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 30 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 31 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 32 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 33 | * SOFTWARE. 34 | * 35 | * This code is part of the SML Compiler Utilities, which can be found at 36 | * 37 | * https://github.com/JohnReppy/sml-compiler-utils 38 | *) 39 | 40 | structure Float16ToLLVM : FLOAT_TO_BITS = 41 | struct 42 | 43 | structure W8A = Word8Array 44 | structure W32 = Word32 45 | structure P16 = PackWord16Big 46 | 47 | structure F16ToBits = FloatToBitsFn (IEEEFloat16Params) 48 | 49 | val ++ = W32.orb 50 | val & = W32.andb 51 | infix 6 ++ 52 | infix 7 & 53 | 54 | (* versions of the PackWord operations that are guaranteed to have Word32.word 55 | * as their argument type (instead of LargeWord.word) 56 | *) 57 | val subVec = W32.fromLarge o P16.subVec 58 | fun update (arr, i, v) = P16.update(arr, i, W32.toLarge v) 59 | 60 | (* offset for converting from the 16-bit exponent-bias (15) to 64-bit bias *) 61 | val biasOffset = W32.fromInt(IEEEFloat64Params.bias - IEEEFloat16Params.bias) 62 | 63 | (* convert a 2-byte Word8Vector that represents a 16-bit IEEE float to a 8-byte 64 | * Word8Vector that represents the corresponding 64-bit float. The conversion 65 | * is similar to the 32-bit conversion. 66 | *) 67 | fun to64 v = let 68 | (* first convert the vector to a Word32 for easy access to bits *) 69 | val bits = subVec(v, 0) 70 | (* mask out components of the 16-bit representation *) 71 | val sign = W32.>>(W32.andb(bits, 0wx8000), 0w15) 72 | val exp16 = W32.>>(W32.andb(bits, 0wx7C00), 0w10) 73 | val man16 = W32.andb(bits, 0wx03FF) 74 | (* convert the SP exponent to DP *) 75 | val exp64 = if (exp16 = 0w0) then 0w0 (* zero *) 76 | else if (exp16 = 0w31) then 0w2047 (* NaN/Inf *) 77 | else exp16 + biasOffset (* not a special exponent *) 78 | (* array to build the result *) 79 | val res = W8A.array(8, 0w0) 80 | in 81 | (* fill high 32 bits of result; the 10 bits of mantissa get shifted to 82 | * fill the upper 20 bits in the result. 83 | *) 84 | update(res, 0, sign ++ W32.<<(exp64, 0w20) ++ W32.<<(man16, 0w10)); 85 | (* low bits are already zero *) 86 | (* convert to a vector for the result *) 87 | W8A.toVector res 88 | end 89 | 90 | (* the number of bits in the literal representation *) 91 | val width = 32 92 | 93 | val classify = F16ToBits.classify 94 | 95 | (* convert a floating-point literal to its IEEE binary representation; we also 96 | * return the IEEE classification of the value. This function raises the 97 | * Overflow exception when the literal is too large to represent. 98 | *) 99 | fun toBits lit = let 100 | val (v, cls) = F16ToBits.toBits lit 101 | in 102 | (to64 v, cls) 103 | end 104 | 105 | (* 106 | val fromBits : Word8Vector.vector -> FloatLit.t 107 | *) 108 | 109 | fun zero isNeg = to64(F16ToBits.zero isNeg) 110 | val negInf = to64(F16ToBits.negInf) 111 | val posInf = to64(F16ToBits.posInf) 112 | val quietNaN = to64(F16ToBits.quietNaN) 113 | 114 | end 115 | -------------------------------------------------------------------------------- /libsrc/Floats/float32-to-llvm.sml: -------------------------------------------------------------------------------- 1 | (* float32-to-llvm-fn.sml 2 | * 3 | * This module supports converting 32-bit float literals to 8-byte bit 4 | * strings suitable for emitting into an LLVM assembler file. 5 | * 6 | * The LLVM assembler expects floating-point literals to be either decimal 7 | * literals that are exactly representable in floating-point, or hexidecimal 8 | * bit strings. For 16, 32, and 64-bit floats, the bit strings must be 9 | * written as 16-digit hexidecimal numbers. This requirement means that 10 | * the bit representation of the exponent and mantissa must be converted 11 | * to double-precision format. 12 | * 13 | * This code is based on code contributed by Kavon Farvardin. 14 | * 15 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 16 | * 17 | * Permission is hereby granted, free of charge, to any person obtaining a copy 18 | * of this software and associated documentation files (the "Software"), to deal 19 | * in the Software without restriction, including without limitation the rights 20 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 21 | * copies of the Software, and to permit persons to whom the Software is 22 | * furnished to do so, subject to the following conditions: 23 | * 24 | * The above copyright notice and this permission notice shall be included in all 25 | * copies or substantial portions of the Software. 26 | * 27 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 28 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 29 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 30 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 31 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 32 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 33 | * SOFTWARE. 34 | * 35 | * This code is part of the SML Compiler Utilities, which can be found at 36 | * 37 | * https://github.com/JohnReppy/sml-compiler-utils 38 | *) 39 | 40 | structure Float32ToLLVM : FLOAT_TO_BITS = 41 | struct 42 | 43 | structure W8A = Word8Array 44 | structure W32 = Word32 45 | structure P32 = PackWord32Big 46 | 47 | structure F32ToBits = FloatToBitsFn (IEEEFloat32Params) 48 | 49 | val ++ = W32.orb 50 | val & = W32.andb 51 | infix 6 ++ 52 | infix 7 & 53 | 54 | (* versions of the PackWord operations that are guaranteed to have Word32.word 55 | * as their argument type (instead of LargeWord.word) 56 | *) 57 | val subVec = W32.fromLarge o P32.subVec 58 | fun update (arr, i, v) = P32.update(arr, i, W32.toLarge v) 59 | 60 | (* offset for converting from the 16-bit exponent-bias (15) to 64-bit bias *) 61 | val biasOffset = W32.fromInt(IEEEFloat64Params.bias - IEEEFloat32Params.bias) 62 | 63 | (* convert a 4-byte Word8Vector that represents a 32-bit IEEE float to a 8-byte 64 | * Word8Vector that represents the corresponding 64-bit float. The conversion 65 | * is as follows: 66 | * 67 | * The exact bit representation of the float is laid out with the 68 | * corresponding bitwise representation of a double: the sign 69 | * bit is copied over, the exponent is encoded in the larger width, 70 | * and the 23 bits of significand fills in the top 23 bits of significand 71 | * in the double. A double has 52 bits of significand, so this means 72 | * that the last 29 bits of significand will always be ignored. As an 73 | * error-detection measure, the IR parser requires them to be zero. 74 | * 75 | * - John McCall's message on the LLVM developer mailing list (2011) 76 | * https://groups.google.com/d/msg/llvm-dev/IlqV3TbSk6M/27dAggZOMb0J 77 | *) 78 | fun to64 v = let 79 | (* first convert the vector to a Word32 for easy access to bits *) 80 | val bits = subVec(v, 0) 81 | (* mask out components of the 32-bit representation *) 82 | val sign = W32.>>(W32.andb(bits, 0wx80000000), 0w31) 83 | val exp32 = W32.>>(W32.andb(bits, 0wx7F800000), 0w23) 84 | val man32 = W32.andb(bits, 0wx007FFFFF) 85 | (* convert the SP exponent to DP *) 86 | val exp64 = if (exp32 = 0w0) then 0w0 (* zero *) 87 | else if (exp32 = 0w255) then 0w2047 (* NaN/Inf *) 88 | else exp32 + biasOffset (* not a special exponent *) 89 | (* array to build the result *) 90 | val res = W8A.array(8, 0w0) 91 | in 92 | (* fill high 32 bits of result *) 93 | update(res, 0, sign ++ W32.<<(exp64, 0w20) ++ W32.>>(man32, 0w3)); 94 | (* construct low 32 bits of result *) 95 | update(res, 1, W32.<<(man32, 0w29)); 96 | (* convert to a vector for the result *) 97 | W8A.toVector res 98 | end 99 | 100 | (* the number of bits in the literal representation *) 101 | val width = 32 102 | 103 | val classify = F32ToBits.classify 104 | 105 | (* convert a floating-point literal to its IEEE binary representation; we also 106 | * return the IEEE classification of the value. This function raises the 107 | * Overflow exception when the literal is too large to represent. 108 | *) 109 | fun toBits lit = let 110 | val (v, cls) = F32ToBits.toBits lit 111 | in 112 | (to64 v, cls) 113 | end 114 | 115 | (* 116 | val fromBits : Word8Vector.vector -> FloatLit.t 117 | *) 118 | 119 | fun zero isNeg = to64(F32ToBits.zero isNeg) 120 | val negInf = to64(F32ToBits.negInf) 121 | val posInf = to64(F32ToBits.posInf) 122 | val quietNaN = to64(F32ToBits.quietNaN) 123 | 124 | end 125 | -------------------------------------------------------------------------------- /libsrc/Floats/sources.cm: -------------------------------------------------------------------------------- 1 | (* sources.cm 2 | * 3 | * CM file to build float code on SML/NJ. 4 | * 5 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | Library 31 | 32 | signature FLOAT_TO_BITS 33 | signature IEEE_FLOAT_PARAMS 34 | 35 | structure FloatConstants 36 | structure FloatLit 37 | structure Float16ToLLVM 38 | structure Float32ToLLVM 39 | structure FloatToLLVMIR 40 | 41 | functor FloatToBitsFn 42 | 43 | structure IEEEFloat16Params 44 | structure IEEEFloat32Params 45 | structure IEEEFloat64Params 46 | structure IEEEFloat128Params 47 | structure IEEEFloat256Params 48 | 49 | is 50 | 51 | $/basis.cm 52 | $/smlnj-lib.cm 53 | 54 | float-constants.sml 55 | float-lit.sml 56 | float-to-bits-fn.sml 57 | float-to-bits-sig.sml 58 | float-to-llvm-ir.sml 59 | float16-to-llvm.sml 60 | float32-to-llvm.sml 61 | 62 | -------------------------------------------------------------------------------- /libsrc/Floats/test.sml: -------------------------------------------------------------------------------- 1 | (* test.sml 2 | * 3 | * Test cases for converting generic float literals. 4 | * 5 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | CM.make "sources.cm"; 31 | 32 | structure F = FloatLit; 33 | 34 | fun equalVec (v1, v2) = (case Word8Vector.collate Word8.compare (v1, v2) 35 | of EQUAL => true 36 | | _ => false 37 | (* end case *)) 38 | 39 | fun bits2s vec = String.concatWithMap 40 | "_" (fn w => StringCvt.padLeft #"0" 8 (Word8.fmt StringCvt.BIN w)) 41 | (Word8Vector.toList vec) 42 | 43 | (* check that serialization is working *) 44 | local 45 | (* check encoding *) 46 | fun checkEnc (lit, expected) = let 47 | val expected = Word8Vector.fromList expected 48 | val res = F.toBytes lit 49 | in 50 | print (concat ( 51 | "check encoding " :: F.toString lit :: 52 | (if equalVec (res, expected) 53 | then [" ok\n"] 54 | else [ 55 | " failed\n", 56 | " expected: ", bits2s expected, "\n", 57 | " result: ", bits2s res, "\n" 58 | ]))) 59 | end 60 | handle ex => print(concat[ 61 | "check encoding ", F.toString lit, " failed (", exnMessage ex, ")\n" 62 | ]) 63 | (* check decoding *) 64 | fun checkDec (expected, bytes) = let 65 | val bytes = Word8Vector.fromList bytes 66 | val res = F.fromBytes bytes 67 | in 68 | print (concat ( 69 | "check decoding " :: F.toString expected :: 70 | (if F.same (res, expected) 71 | then [" ok\n"] 72 | else [" failed; result = ", F.toString res, "\n"]))) 73 | end 74 | handle ex => print(concat[ 75 | "check decoding ", F.toString expected, " failed (", exnMessage ex, ")\n" 76 | ]) 77 | (* check round-trip *) 78 | fun check lit = let 79 | val enc = F.toBytes lit 80 | val dec = F.fromBytes enc 81 | in 82 | print (concat ("check encode/decode " :: F.toString lit :: 83 | (if F.same (lit, dec) 84 | then [" ok\n"] 85 | else [ 86 | " failed\n", 87 | " encoded: ", bits2s enc, "\n", 88 | " decoded: ", F.toString dec, "\n" 89 | ]))) 90 | end 91 | handle ex => print(concat[ 92 | "check encode/decode ", F.toString lit, " failed (", exnMessage ex, ")\n" 93 | ]) 94 | in 95 | val _ = ( 96 | (* 0 *) 97 | checkEnc (F.zero false, [0w0, 0w0, 0w0, 0w0, 0w0]); 98 | (* -0 *) 99 | checkEnc (F.zero true, [0w1, 0w0, 0w0, 0w0, 0w0]); 100 | (* 1 *) 101 | checkEnc (F.one, [0w0, 0w1, 0w0, 0w0, 0w0, 0w1]); 102 | (* 2 *) 103 | checkEnc (F.fromDigits{isNeg=false, digits=[2], exp=1}, 104 | [0w0, 0w2, 0w0, 0w0, 0w0, 0w1]); 105 | (* -2 *) 106 | checkEnc (F.fromDigits{isNeg=true, digits=[2], exp=1}, 107 | [0w1, 0w2, 0w0, 0w0, 0w0, 0w1]); 108 | (* 0.25 *) 109 | checkEnc (F.fromDigits{isNeg=false, digits=[2,5], exp=0}, 110 | [0w0, 0w2, 0w5, 0w0, 0w0, 0w0, 0w0])) 111 | val _ = ( 112 | (* 0 *) 113 | checkDec (F.zero false, [0w0, 0w0, 0w0, 0w0, 0w0]); 114 | (* -0 *) 115 | checkDec (F.zero true, [0w1, 0w0, 0w0, 0w0, 0w0]); 116 | (* 1 *) 117 | checkDec (F.one, [0w0, 0w1, 0w0, 0w0, 0w0, 0w1]); 118 | (* 2 *) 119 | checkDec (F.fromDigits{isNeg=false, digits=[2], exp=1}, 120 | [0w0, 0w2, 0w0, 0w0, 0w0, 0w1]); 121 | (* -2 *) 122 | checkDec (F.fromDigits{isNeg=true, digits=[2], exp=1}, 123 | [0w1, 0w2, 0w0, 0w0, 0w0, 0w1]); 124 | (* 0.25 *) 125 | checkDec (F.fromDigits{isNeg=false, digits=[2,5], exp=0}, 126 | [0w0, 0w2, 0w5, 0w0, 0w0, 0w0, 0w0])) 127 | val _ = ( 128 | check FloatConstants.M_PI) 129 | end; (* local *) 130 | -------------------------------------------------------------------------------- /libsrc/Floats/test32.sml: -------------------------------------------------------------------------------- 1 | (* test32.sml 2 | * 3 | * Test cases for converting float literals to IEEE double-precision floats (64-bit) 4 | * See http://www.binaryconvert.com/result_float.html for an online converter. 5 | * 6 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | CM.make "sources.cm"; 32 | 33 | structure F32ToBits = FloatToBitsFn (IEEEFloat32Params); 34 | 35 | fun equalVec (v1, v2) = (case Word8Vector.collate Word8.compare (v1, v2) 36 | of EQUAL => true 37 | | _ => false 38 | (* end case *)) 39 | 40 | fun bits2s vec = String.concatWithMap 41 | "_" (fn w => StringCvt.padLeft #"0" 8 (Word8.fmt StringCvt.BIN w)) 42 | (Word8Vector.toList vec) 43 | 44 | fun check (lit, expected) = let 45 | val (res, _) = F32ToBits.toBits lit 46 | in 47 | print (concat ( 48 | "check " :: FloatLit.toString lit :: 49 | (if equalVec (res, expected) 50 | then [" ok\n"] 51 | else [ 52 | " failed\n", 53 | " expected: ", bits2s expected, "\n", 54 | " result: ", bits2s res, "\n" 55 | ]))) 56 | end 57 | handle Overflow => print "failed (too large)\n" 58 | | ex => print(concat[" failed (", exnMessage ex, ")\n"]) 59 | 60 | fun check' (sign, digits, exp, expected) = 61 | check ( 62 | FloatLit.fromDigits {isNeg = sign, digits = digits, exp = exp}, 63 | Word8Vector.fromList expected); 64 | 65 | val _ = ( 66 | (* 0 *) 67 | check' (false, [0], 0, [0wx00, 0wx00, 0wx00, 0wx00]); 68 | (* -0 *) 69 | check' (true, [0], 0, [0wx80, 0wx00, 0wx00, 0wx00]); 70 | (* 1 *) 71 | check' (false, [1], 1, [0wx3f, 0wx80, 0wx00, 0wx00]); 72 | (* 2 *) 73 | check' (false, [2], 1, [0wx40, 0wx00, 0wx00, 0wx00]); 74 | (* -2 *) 75 | check' (true, [2], 1, [0wxc0, 0wx00, 0wx00, 0wx00]); 76 | (* 0.25 *) 77 | check' (false, [2,5], 0, [0wx3e, 0wx80, 0wx00, 0wx00]); 78 | (* 0.15 *) 79 | check' (false, [1,5], 0, [0wx3e, 0wx19, 0wx99, 0wx9A]); 80 | (* 1.5 *) 81 | check' (false, [1,5], 1, [0wx3f, 0wxc0, 0wx00, 0wx00]); 82 | (* pi *) 83 | check (FloatConstants.M_PI, Word8Vector.fromList[0wx40, 0wx49, 0wx0F, 0wxDB]); 84 | (* Min normal positive float: 1.175494351 × 10^{−38} *) 85 | check' (false, [1,1,7,5,4,9,4,3,5,1], ~37, 86 | [0wx00, 0wx80, 0wx00, 0wx00]); 87 | (* Max float: 3.402823466 × 10^{38} *) 88 | check' (false, [3,4,0,2,8,2,3,4,6,6], 39, 89 | [0wx7f, 0wx7f, 0wxff, 0wxff]); 90 | ()); 91 | -------------------------------------------------------------------------------- /libsrc/Floats/test64.sml: -------------------------------------------------------------------------------- 1 | (* test64.sml 2 | * 3 | * Test cases for converting float literals to IEEE double-precision floats (64-bit) 4 | * See http://www.binaryconvert.com/result_double.html for an online converter. 5 | * 6 | * COPYRIGHT (c) 2018 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | CM.make "sources.cm"; 32 | 33 | structure F64ToBits = FloatToBitsFn (IEEEFloat64Params); 34 | 35 | fun equalVec (v1, v2) = (case Word8Vector.collate Word8.compare (v1, v2) 36 | of EQUAL => true 37 | | _ => false 38 | (* end case *)) 39 | 40 | fun bits2s vec = String.concatWithMap 41 | "_" (fn w => StringCvt.padLeft #"0" 8 (Word8.fmt StringCvt.BIN w)) 42 | (Word8Vector.toList vec) 43 | 44 | fun check (lit, expected) = let 45 | val expected = Word8Vector.fromList expected 46 | val (res, _) = F64ToBits.toBits lit 47 | in 48 | print (concat ( 49 | "check " :: FloatLit.toString lit :: 50 | (if equalVec (res, expected) 51 | then [" ok\n"] 52 | else [ 53 | " failed\n", 54 | " expected: ", bits2s expected, "\n", 55 | " result: ", bits2s res, "\n" 56 | ]))) 57 | end 58 | handle Overflow => print "failed (too large)\n" 59 | | ex => print(concat[" failed (", exnMessage ex, ")\n"]) 60 | 61 | fun check' (sign, digits, exp, expected) = 62 | check ( 63 | FloatLit.fromDigits {isNeg = sign, digits = digits, exp = exp}, 64 | expected); 65 | 66 | val _ = ( 67 | (* 0 *) 68 | check' (false, [0], 0, [0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 69 | (* -0 *) 70 | check' (true, [0], 0, [0wx80, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 71 | (* 1 *) 72 | check' (false, [1], 1, [0wx3f, 0wxf0, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 73 | (* 2 *) 74 | check' (false, [2], 1, [0wx40, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 75 | (* -2 *) 76 | check' (true, [2], 1, [0wxc0, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 77 | (* 0.25 *) 78 | check' (false, [2,5], 0,[0wx3f, 0wxd0, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 79 | (* 1.5 *) 80 | check' (false, [1,5], 1,[0wx3F, 0wxF8, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 81 | (* pi *) 82 | check (FloatConstants.M_PI, 83 | [0wx40, 0wx09, 0wx21, 0wxFB, 0wx54, 0wx44, 0wx2D, 0wx18]); 84 | (* Min normal positive double: 2.2250738585072014 × 10^{−308} *) 85 | check' (false, [2,2,2,5,0,7,3,8,5,8,5,0,7,2,0,1,4], ~307, 86 | [0wx00, 0wx10, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 87 | (* Max double: 1.7976931348623157 × 10^{308} *) 88 | check' (false, [1,7,9,7,6,9,3,1,3,4,8,6,2,3,1,5,7], 309, 89 | [0wx7f, 0wxef, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff]); 90 | (* Max sub-normal positive double: 2.2250738585072009 × 10^{−308} *) 91 | check' (false, [2,2,2,5,0,7,3,8,5,8,5,0,7,2,0,0,9], ~307, 92 | [0wx00, 0wx0f, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff, 0wxff]); 93 | (* sub-normal number: 9.8813129168249309 × 10^{-324} *) 94 | check' (false, [9,8,8,1,3,1,2,9,1,6,8,2,4,9,3,0,9], ~323, 95 | [0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx02]); 96 | (* Min sub-normal positive double: 4.9406564584124654 × 10^{-324} *) 97 | check' (false, [4,9,4,0,6,5,6,4,5,8,4,1,2,4,6,5,4,5], ~323, 98 | [0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx01]); 99 | (* Negative infinity *) 100 | check (FloatLit.negInf, [0wxff, 0wxf0, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 101 | (* Positive infinity *) 102 | check (FloatLit.posInf, [0wx7f, 0wxf0, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00, 0wx00]); 103 | ()); 104 | -------------------------------------------------------------------------------- /libsrc/Logging/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Logging 2 | 3 | This library collects together various modules for tracking the performance 4 | of a compiler. 5 | 6 | ### Modules 7 | 8 | The `PhaseTimer` module supports a hierarchy of timers for tracking the 9 | time spent in compiler phases. 10 | 11 | The `Log` module implements a log file for compiler diagnostic messages. 12 | It includes helper functions for reporting phase timings and for checking 13 | IR invariants. 14 | 15 | The `Stats` module implements a hierarchy of integer counters for tracking 16 | information about a program (*e.g.*, the number of times a particular 17 | optimization is performed). 18 | 19 | ### Dependencies 20 | 21 | The `Log` module depends on the `Controls`, and the `PhaseTimer` and `Stats` 22 | modules depend on the `JSON` modules from the 23 | **SML/NJ Library**. Add 24 | 25 | ```` 26 | $/controls-lib.cm 27 | $/json-lib.cm 28 | ```` 29 | 30 | to your CM file, or 31 | 32 | ```` 33 | $(SML_LIB)/smlnj-lib/Controls/controls-lib.mlb 34 | $(SML_LIB)/smlnj-lib/JSON/json-lib.mlb 35 | ```` 36 | 37 | to your MLB file, to include the necessary prerequisites. 38 | -------------------------------------------------------------------------------- /libsrc/Logging/log.sml: -------------------------------------------------------------------------------- 1 | (* log.sml 2 | * 3 | * Support for logging internal messages to a log file. 4 | * 5 | * COPYRIGHT (c) 2020 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | structure Log : sig 31 | 32 | (* is logging enabled? *) 33 | val enabled : unit -> bool 34 | 35 | (* initialize logging to the specified file name; use "-" as the file name to 36 | * direct output to stdout. 37 | *) 38 | val init : string -> unit 39 | 40 | (* get the name of the log file; returns the empty string when logging is not 41 | * enabled and "-" for stdout. 42 | *) 43 | val filename : unit -> string 44 | 45 | (* terminate logging and close the log file *) 46 | val finish : unit -> unit 47 | 48 | (* return the output stream being used for logging. This function raises 49 | * the `Fail` exception when logging has not been initialized. 50 | *) 51 | val outstream : unit -> TextIO.outstream 52 | 53 | (* output a message to the log; is a no-op if logging is not enabled *) 54 | val msg : string list -> unit 55 | 56 | (* if logging is enabled, evaluate the function and output its result to the log *) 57 | val msg' : (unit -> string list) -> unit 58 | 59 | (* `after { dumpCtl, checkCtl, output, checkIR, fail } (phase, ir)` supports 60 | * conditional dumping and checking of `ir`. The IR `ir` is output to the 61 | * log using the `output` function if either the `dumpCtl` is set or 62 | * the `checkCtl` is set and `checkIR` returns `true`. In addition, if 63 | * `checkIR` returns true, then the function `fail` is called with an 64 | * error message. 65 | *) 66 | val after : { 67 | dumpCtl : bool Controls.control, 68 | checkCtl : bool Controls.control, 69 | output : TextIO.outstream * string * 'prog -> unit, 70 | checkIR : string * 'prog -> bool, 71 | fail : string -> unit 72 | } -> string * 'prog -> 'prog 73 | 74 | (* report timing to the log file *) 75 | val reportTiming : PhaseTimer.t -> unit 76 | 77 | end = struct 78 | 79 | val enabledFlg = ref false 80 | val logStrm : TextIO.outstream option ref = ref NONE 81 | val logFile = ref "" 82 | 83 | fun enabled () = !enabledFlg 84 | 85 | fun initStrm outS = ( 86 | (* turn off buffering *) 87 | TextIO.StreamIO.setBufferMode (TextIO.getOutstream outS, IO.NO_BUF); 88 | logStrm := SOME outS) 89 | 90 | fun init file = (case !logStrm 91 | of NONE => ( 92 | enabledFlg := true; 93 | if file = "-" 94 | then ( 95 | initStrm TextIO.stdOut; 96 | logFile := "") 97 | else ( 98 | initStrm (TextIO.openOut file); 99 | logFile := file)) 100 | | SOME strm => raise Fail "multiple initialization of log file" 101 | (* end case *)) 102 | 103 | fun filename () = !logFile 104 | 105 | fun finish () = (case !logStrm 106 | of SOME strm => ( 107 | if !logFile <> "" then TextIO.closeOut strm else (); 108 | enabledFlg := false; 109 | logFile := ""; 110 | logStrm := NONE) 111 | | NONE => () 112 | (* end case *)) 113 | 114 | fun outstream () = (case !logStrm 115 | of NONE => raise Fail "log file is not initialized" 116 | | SOME outS => outS 117 | (* end case *)) 118 | 119 | fun msg s = if !enabledFlg then TextIO.output(outstream(), String.concat s) else () 120 | 121 | fun msg' msgFn = if !enabledFlg 122 | then TextIO.output(outstream(), String.concat(msgFn())) 123 | else () 124 | 125 | fun after {dumpCtl, checkCtl, output, checkIR, fail} (phase, prog) = let 126 | fun dump () = if !enabledFlg 127 | then output(outstream(), "after " ^ phase, prog) 128 | else output(TextIO.stdErr, "after " ^ phase, prog) 129 | in 130 | if Controls.get dumpCtl andalso !enabledFlg 131 | then dump() 132 | else (); 133 | if Controls.get checkCtl andalso checkIR("after " ^ phase, prog) 134 | then ( 135 | if not(Controls.get dumpCtl) (* avoid duplication *) 136 | then dump() 137 | else (); 138 | fail (concat [ 139 | "***** Internal error after ", phase, ": see ", 140 | filename(), " for details\n" 141 | ])) 142 | else (); 143 | prog 144 | end 145 | 146 | fun reportTiming timer = PhaseTimer.report (outstream(), timer) 147 | 148 | end 149 | 150 | -------------------------------------------------------------------------------- /libsrc/Logging/phase-timer.sml: -------------------------------------------------------------------------------- 1 | (* phase-timer.sml 2 | * 3 | * Support for timing compiler phases with nesting (similar to the idea of "cost centers"). 4 | * 5 | * COPYRIGHT (c) 2020 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | structure PhaseTimer : sig 31 | 32 | type t 33 | 34 | (* create a new top-level timer with the given name *) 35 | val newTimer : string -> t 36 | 37 | (* create a sub-phase timer with the given name. Any time measured by this timer 38 | * will also be assigned to the ancestor of this timer. 39 | *) 40 | val newPhase : t * string -> t 41 | 42 | (* start a timer; note that the starting and stopping of timers should respect the 43 | * nesting of the timers. 44 | *) 45 | val start : t -> unit 46 | 47 | (* stop/pause a timer *) 48 | val stop : t -> unit 49 | 50 | (* wrap a function with a timer; i.e., the timer is started when the function is 51 | * called and stopped when it returns (or raises an exception). 52 | *) 53 | val withTimer : t -> ('a -> 'b) -> 'a -> 'b 54 | 55 | (* generate a report about the timers. The format of the report is controled 56 | * by the flags, which have the following meanings: 57 | * 58 | * prefix -- a prefix prepended to every line of the report 59 | * wid -- a desired line width (including prefix). The output 60 | * will be at least this wide, but may be wider. 61 | * sepChr -- a character used as the separator between the name 62 | * and values 63 | * noZeros -- if true, counters with zero value are omitted 64 | *) 65 | val fmtReport : { 66 | prefix : string, 67 | wid : int, 68 | sepChr : char, 69 | noZeros : bool 70 | } -> TextIO.outstream * t -> unit 71 | 72 | (* equivalent to `fmtReport {prefix = "", wid = 60, sepChr = #".", noZeros = false}` *) 73 | val report : TextIO.outstream * t -> unit 74 | 75 | (* return a JSON object that captures the values of the timers. *) 76 | val toJSON : t -> JSON.value 77 | 78 | end = struct 79 | 80 | datatype t = T of { 81 | parent : t option, (* optional parent of this timer *) 82 | label : string, (* name of the timer *) 83 | start : Time.time option ref, (* SOME t when on, otherwise NONE *) 84 | tot : Time.time ref, (* total accumulated time for the timer *) 85 | childTot : Time.time ref, (* time accumulated by its immediate kids *) 86 | children : t list ref (* list of kids *) 87 | } 88 | 89 | fun newTimer l = T{ 90 | parent = NONE, 91 | label = l, 92 | start = ref NONE, 93 | tot = ref Time.zeroTime, 94 | childTot = ref Time.zeroTime, 95 | children = ref [] 96 | } 97 | 98 | fun newPhase (timer as T{children, ...}, l) = let 99 | val newT = T{ 100 | parent = SOME timer, 101 | label = l, 102 | start = ref NONE, 103 | tot = ref Time.zeroTime, 104 | childTot = ref Time.zeroTime, 105 | children = ref [] 106 | } 107 | in 108 | children := newT :: !children; 109 | newT 110 | end 111 | 112 | fun start (T{label, start, parent, ...}) = (case !start 113 | of NONE => ( 114 | start := SOME(Time.now()); 115 | case parent 116 | of SOME(T{start=ref NONE, label=lab, ...}) => raise Fail(concat[ 117 | "start(", label, "): parent (", lab, ") is not running" 118 | ]) 119 | | _ => ()) 120 | | SOME _ => () 121 | (* end case *)) 122 | 123 | fun stop (T{label, parent, start, tot, ...}) = (case !start 124 | of SOME t0 => let 125 | val t = Time.-(Time.now(), t0) 126 | in 127 | start := NONE; 128 | tot := Time.+(!tot, t); 129 | case parent 130 | of SOME(T{childTot, ...}) => childTot := Time.+(!childTot, t) 131 | | _ => () 132 | (* end case *) 133 | end 134 | | NONE => () 135 | (* end case *)) 136 | 137 | fun withTimer timer f x = let 138 | val () = start timer 139 | val y = (f x) handle ex => (stop timer; raise ex) 140 | in 141 | stop timer; 142 | y 143 | end 144 | 145 | fun fmtReport {prefix, wid, sepChr, noZeros} (outS, timer) = let 146 | fun pr s = TextIO.output(outS, s) 147 | (* create a string by repeating a character n times *) 148 | fun repeat (c, n) = CharVector.tabulate(n, Fn.const c) 149 | val leftPad = StringCvt.padLeft #" " 150 | fun time2s t = leftPad 7 (Time.fmt 3 t) 151 | (* gather the lines for the report *) 152 | val lns = let 153 | fun walk depth (T{label, children, tot, childTot, ...}, lns) = let 154 | val label = leftPad (2 * depth + size label) label 155 | val t1 = let 156 | val t = Time.-(!tot, !childTot) 157 | (* avoid negative times because of non-monotonic clocks *) 158 | val t = if Time.<(t, Time.zeroTime) 159 | then Time.zeroTime 160 | else t 161 | in 162 | time2s t 163 | end 164 | val t2 = time2s (!tot) 165 | in 166 | (* NOTE: we use foldl to reverse the order of the kids *) 167 | (label, t1, t2) :: 168 | List.foldl 169 | (walk (depth + 1)) 170 | lns 171 | (!children) 172 | end 173 | in 174 | walk 0 (timer, []) 175 | end 176 | (* determine maximum field widths *) 177 | fun mx (s, m) = Int.max(size s, m) 178 | val (max1, max2, max3) = List.foldl 179 | (fn ((s1, s2, s3), (m1, m2, m3)) => (mx(s1, m1), mx(s2, m2), mx(s2, m2))) 180 | (0, 0, 0) 181 | lns 182 | (* determine the separator width *) 183 | val sepWid = wid - size prefix - (max1 + 1) - (max2 + 1) - 2 - max3 184 | (* the right padding for the label *) 185 | val pad1 = StringCvt.padRight sepChr (max1 + 1) 186 | fun fmt1 name = pad1 (name ^ " ") 187 | (* the minimum seperator is " .... " *) 188 | val sep = repeat (sepChr, sepWid - 2) 189 | (* print a line *) 190 | fun prLn (label, t1, t2) = pr (concat [ 191 | prefix, fmt1 label, sep, " ", t1, " ", t2, "\n" 192 | ]) 193 | (* center a string in a field of the given width *) 194 | fun center (s, wid) = let 195 | val padding = wid - String.size s 196 | val lPad = padding div 2 197 | val rPad = padding - lPad 198 | in 199 | if padding < 0 then s 200 | else concat[repeat(#" ", lPad), s, repeat(#" ", rPad)] 201 | end 202 | in 203 | pr prefix; 204 | pr (center ("Phase", max1 + sepWid)); 205 | pr " "; pr(center ("Exclusive", max2 + 2)); 206 | pr " "; pr(center ("Total", max3 + 1)); 207 | pr "\n"; 208 | List.app prLn lns 209 | end 210 | 211 | (* 212 | fun report (outS, timer) = let 213 | fun pr s = TextIO.output(outS, s) 214 | (* create a string by repeating a character n times *) 215 | fun repeat (c, n) = CharVector.tabulate(n, Fn.const c) 216 | (* figure out the length of the longest label in the tree and the depth of the tree *) 217 | val (maxLabelLen, depth) = let 218 | fun walk (T{label, children, ...}, maxLen, depth) = let 219 | fun doChild (timer, (maxLen, depth)) = let 220 | val (l, d) = walk (timer, maxLen, depth) 221 | in 222 | (Int.max(maxLen, l), Int.max(depth, d)) 223 | end 224 | in 225 | List.foldl 226 | doChild 227 | (Int.max(size label, maxLen), depth+1) 228 | (!children) 229 | end 230 | in 231 | walk (timer, 0, 0) 232 | end 233 | val labelWid = maxLabelLen + 2*depth + 4 234 | (* display a report line *) 235 | fun display (indent, T{label, tot, childTot, children, ...}) = let 236 | fun prTime t = pr(StringCvt.padLeft #" " 7 (Time.fmt 3 t)) 237 | in 238 | pr(repeat (#" ", indent)); 239 | pr(StringCvt.padRight #"." (labelWid+4-indent) (label^" ")); 240 | pr " "; prTime (Time.-(!tot, !childTot)); 241 | pr " "; prTime (!tot); pr "\n"; 242 | List.app (fn t => display(indent+2, t)) (List.rev (!children)) 243 | end 244 | fun center (s, wid) = let 245 | val padding = wid - String.size s 246 | val lPad = padding div 2 247 | val rPad = padding - lPad 248 | in 249 | if padding < 0 then s 250 | else concat[repeat(#" ", lPad), s, repeat(#" ", rPad)] 251 | end 252 | in 253 | pr (center ("Phase", labelWid + 2)); 254 | pr " "; pr(center ("Exclusive", 9)); 255 | pr " "; pr(center ("Total", 9)); 256 | pr "\n"; 257 | display (2, timer) 258 | end 259 | *) 260 | 261 | val report = fmtReport {prefix = "", wid = 72, sepChr = #".", noZeros = false} 262 | 263 | fun toJSON timer = let 264 | fun timeToJSON t = JSON.FLOAT(Time.toReal t) 265 | fun timerToJSON (T{label, tot, childTot, children, ...}) = let 266 | val fields = if null(!children) 267 | then [] 268 | else [("kids", JSON.ARRAY(List.revMap timerToJSON (!children)))] 269 | val exclT = let 270 | val t = Time.-(!tot, !childTot) 271 | in 272 | if Time.<(t, Time.zeroTime) 273 | then Time.zeroTime 274 | else t 275 | end 276 | val fields = ("label", JSON.STRING label) :: 277 | ("total", timeToJSON (!tot)) :: 278 | ("exclusive", timeToJSON exclT) :: 279 | fields 280 | in 281 | JSON.OBJECT fields 282 | end 283 | in 284 | timerToJSON timer 285 | end 286 | 287 | end 288 | -------------------------------------------------------------------------------- /libsrc/Logging/sources.cm: -------------------------------------------------------------------------------- 1 | (* sources.cm 2 | * 3 | * CM file to build logging code. 4 | * 5 | * Permission is hereby granted, free of charge, to any person obtaining a copy 6 | * of this software and associated documentation files (the "Software"), to deal 7 | * in the Software without restriction, including without limitation the rights 8 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | * copies of the Software, and to permit persons to whom the Software is 10 | * furnished to do so, subject to the following conditions: 11 | * 12 | * The above copyright notice and this permission notice shall be included in all 13 | * copies or substantial portions of the Software. 14 | * 15 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | * SOFTWARE. 22 | * 23 | * This code is part of the SML Compiler Utilities, which can be found at 24 | * 25 | * https://github.com/JohnReppy/sml-compiler-utils 26 | *) 27 | 28 | Library 29 | 30 | structure Log 31 | structure PhaseTimer 32 | structure Stats 33 | 34 | is 35 | 36 | $/basis.cm 37 | $/smlnj-lib.cm 38 | $/controls-lib.cm 39 | $/json-lib.cm 40 | 41 | log.sml 42 | phase-timer.sml 43 | stats.sml 44 | -------------------------------------------------------------------------------- /libsrc/Logging/stats.sml: -------------------------------------------------------------------------------- 1 | (* stats.sml 2 | * 3 | * Support for collecting statistics about the internal actions in a 4 | * compiler. 5 | * 6 | * COPYRIGHT (c) 2020 John Reppy (https://cs.uchicago.edu/~jhr) 7 | * 8 | * Permission is hereby granted, free of charge, to any person obtaining a copy 9 | * of this software and associated documentation files (the "Software"), to deal 10 | * in the Software without restriction, including without limitation the rights 11 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | * copies of the Software, and to permit persons to whom the Software is 13 | * furnished to do so, subject to the following conditions: 14 | * 15 | * The above copyright notice and this permission notice shall be included in all 16 | * copies or substantial portions of the Software. 17 | * 18 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 24 | * SOFTWARE. 25 | * 26 | * This code is part of the SML Compiler Utilities, which can be found at 27 | * 28 | * https://github.com/JohnReppy/sml-compiler-utils 29 | *) 30 | 31 | structure Stats : sig 32 | 33 | type group 34 | type counter 35 | 36 | (* if true, we log individual optimization ticks as they are recorded *) 37 | val logTicks : bool ref 38 | 39 | (* used to order the groups when reporting results *) 40 | type priority = int list 41 | 42 | structure Group : sig 43 | (* a group of counters *) 44 | type t = group 45 | 46 | (* the group that contains all of the top-level groups *) 47 | val root : t 48 | 49 | (* `new parent name` creates a new group that is a subgroup of `parent`. 50 | * The group is given a default priority based on its creation order; 51 | * _i.e._, the first subgroup is assigned priority `[1]`, the second 52 | * is assigned `[2]`, _etc_. 53 | *) 54 | val new : t -> string -> t 55 | 56 | (* `newWithPri parent (name, pri)` creates a new group that is a 57 | * subgroup of `parent` and that has the specified priority. 58 | *) 59 | val newWithPri : t -> string * priority -> t 60 | 61 | (* return the name of the group. The root group's name is "" *) 62 | val name : t -> string 63 | 64 | (* return the group's parent; `NONE` for the root. *) 65 | val parent : t -> t option 66 | 67 | (* reset the counters in the group (and all subgroups) *) 68 | val reset : t -> unit 69 | 70 | (* return the sum of the counters in the group (and all subgroups) *) 71 | val total : t -> int 72 | 73 | (* `hide (grp, true)` marks the group as `hidden` (_i.e._, is does not 74 | * appear in any reports). One can "un-hide" a group with the call 75 | * `hide (grp, false)`. 76 | *) 77 | val hide : t * bool -> unit 78 | 79 | (* `hidden grp` returns `true` if the group is currently hidden. *) 80 | val hidden : t -> bool 81 | 82 | (* `subgroups grp` returns a list of the subgroups of `grp` in the 83 | * order in which they were created. 84 | *) 85 | val subgroups : t -> t list 86 | 87 | (* `subgroupsInOrder grp` returns a list of the subgroups of 88 | * `grp` in priority order in which they were created. If the 89 | * subgroups were all created using `new`, this function behaves 90 | * the same as `subgroups`. 91 | *) 92 | val subgroupsInOrder : t -> t list 93 | 94 | (* `counters grp` returns a list of the counters in the 95 | * group in the order in which they were created. 96 | *) 97 | val counters : t -> counter list 98 | 99 | (* `fmtReport flgs (outS, grp)` generates a report of the counter values 100 | * to `outS`. The report's format is controlled by the `flgs` record, 101 | * which has the following fields: 102 | * 103 | * prefix -- a prefix prepended to every line of the report 104 | * wid -- a desired line width (including prefix). The output 105 | * will be at least this wide, but may be wider. 106 | * sepChr -- a character used as the separator between the name 107 | * and values 108 | * noZeros -- if true, counters with zero value are omitted 109 | * grpHdrs -- if true, a header line is printed before each non-empty 110 | * group (non-empty is judged after filtering for zeros 111 | * and hidden subgroups) 112 | * fullNames -- if true, the full names of counters are displayed. 113 | *) 114 | val fmtReport : { 115 | prefix : string, 116 | wid : int, 117 | sepChr : char, 118 | noZeros : bool, 119 | grpHdrs : bool, 120 | fullNames : bool 121 | } -> TextIO.outstream * t -> unit 122 | 123 | (* `report (outS, grp)` generates a report to the specified output stream. 124 | * This call is shorthand for 125 | * 126 | * fmtReport 127 | * { prefix = "", 128 | * wid = 72, sepChr = #".", noZeros = true, 129 | * grpHdrs=false, fullNames=true 130 | * } 131 | * (outS, grp) 132 | *) 133 | val report : TextIO.outstream * t -> unit 134 | 135 | (* return a JSON object that captures the values of the counters. *) 136 | val toJSON : t -> JSON.value 137 | 138 | end 139 | 140 | structure Counter : sig 141 | (* a counter *) 142 | type t = counter 143 | 144 | (* `new grp name` allocates a new counter in the specified group. *) 145 | val new : Group.t -> string -> t 146 | 147 | (* return the counter's name *) 148 | val name : t -> string 149 | 150 | (* get the full name of a counter, which will be a string of the form 151 | * `grp1/grp2/.../name`, where `grp1` etc. are the names of the containing 152 | * groups (not counting the root group), 153 | *) 154 | val fullName : t -> string 155 | 156 | (* `tick cntr` adds one to the counter's value. If the `logTicks` flag 157 | * is set, then a log message is also generated. 158 | *) 159 | val tick : t -> unit 160 | 161 | (* `bump (cntr, n)` adds `n` to the counter. Note that unlike `tick`, this 162 | * operation does *not* generate a log message when `logTicks` is set. 163 | *) 164 | val bump : t * int -> unit 165 | 166 | (* `value cntr` returns the current value of the counter *) 167 | val value : t -> int 168 | 169 | (* `reset cntr` resets the counter's value to zero. *) 170 | val reset : t -> unit 171 | 172 | end 173 | 174 | end = struct 175 | 176 | (* used to order the groups when reporting results *) 177 | type priority = int list 178 | 179 | datatype group = G of { 180 | name : string, 181 | parent : group option, 182 | pri : priority, 183 | hidden : bool ref, 184 | nextId : int ref, 185 | kids : group list ref, 186 | counters : counter list ref 187 | } 188 | 189 | and counter = C of { 190 | grp : group, 191 | name : string, 192 | cnt : int ref 193 | } 194 | 195 | val logTicks = ref false 196 | 197 | (* get the full name of a counter *) 198 | fun cntrFullName (C{grp, name, ...}) = let 199 | fun get (G{parent=NONE, ...}, l) = String.concat l 200 | | get (G{parent=SOME grp, name, ...}, l) = 201 | get (grp, name :: "/" :: l) 202 | in 203 | get (grp, [name]) 204 | end 205 | 206 | (* get the full name of a counter *) 207 | fun grpFullName (G{parent=NONE, ...}) = "" 208 | | grpFullName (G{parent=SOME grp, name, ...}) = let 209 | fun get (G{parent=NONE, ...}, l) = String.concat l 210 | | get (G{parent=SOME grp, name, ...}, l) = 211 | get (grp, name :: "/" :: l) 212 | in 213 | get (grp, [name]) 214 | end 215 | 216 | structure Group = 217 | struct 218 | 219 | type t = group 220 | 221 | fun mk (name, parent, pri) = G{ 222 | name = name, 223 | parent = parent, 224 | pri = pri, 225 | hidden = ref false, 226 | nextId = ref 1, 227 | kids = ref[], 228 | counters = ref[] 229 | } 230 | 231 | (* the group that contains all of the top-level groups *) 232 | val root = mk ("", NONE, []) 233 | 234 | fun new (parent as G{nextId, kids, ...}) name = let 235 | val id = !nextId 236 | val grp = mk (name, SOME parent, [id]) 237 | in 238 | nextId := id + 1; 239 | kids := grp :: !kids; 240 | grp 241 | end 242 | 243 | fun newWithPri (parent as G{kids, ...}) (name, pri) = let 244 | val grp = mk (name, SOME parent, pri) 245 | in 246 | kids := grp :: !kids; 247 | grp 248 | end 249 | 250 | fun name (G{name, ...}) = name 251 | fun parent (G{parent, ...}) = parent 252 | 253 | fun reset (G{kids, counters, ...}) = ( 254 | List.app reset (!kids); 255 | List.app (fn (C{cnt, ...}) => cnt := 0) (!counters)) 256 | 257 | fun total grp = let 258 | fun sum (G{kids, counters, ...}, n) = 259 | List.foldl sum 260 | (List.foldl (fn (C{cnt, ...}, m) => m + !cnt) n (!counters)) 261 | (!kids) 262 | in 263 | sum (grp, 0) 264 | end 265 | 266 | fun hide (G{hidden, ...}, b) = hidden := b 267 | fun hidden (G{hidden, ...}) = !hidden 268 | 269 | (* sort a list of groups into priority order *) 270 | val sort = let 271 | fun gt (G{pri=p1, ...}, G{pri=p2, ...}) = ( 272 | case List.collate Int.compare (p1, p2) 273 | of GREATER => true 274 | | _ => false 275 | (* end case *)) 276 | in 277 | ListMergeSort.sort gt 278 | end 279 | 280 | fun subgroups (G{kids, ...}) = List.rev (!kids) 281 | fun subgroupsInOrder (G{kids, ...}) = sort (!kids) 282 | fun counters (G{counters, ...}) = List.rev (!counters) 283 | 284 | fun fmtReport {prefix, wid, sepChr, noZeros, grpHdrs, fullNames} (outS, grp) = let 285 | fun itos n = if (n < 0) then "-" ^ Int.toString(~n) else Int.toString n 286 | fun getCounters (cntrs, lns) = let 287 | fun get (cntr as C{name, cnt, ...}, lns) = ( 288 | case (noZeros, fullNames, !cnt) 289 | of (true, _, 0) => lns 290 | | (_, false, n) => (name, itos n) :: lns 291 | | (_, true, n) => (cntrFullName cntr, itos n) :: lns 292 | (* end case *)) 293 | in 294 | (* Note: the list of counters is in reverse order, so using 295 | * foldl here will return the result in creation order. 296 | *) 297 | List.foldl get lns cntrs 298 | end 299 | (* we walk the group tree and gather up a list of output lines *) 300 | fun getLines (grp as G{name, kids, counters, hidden, ...}, lns') = 301 | if !hidden 302 | then lns' 303 | else let 304 | (* lines for the subgroups *) 305 | val lns = List.foldr getLines [] (sort (!kids)) 306 | (* lines for the counters are prepended *) 307 | val lns = getCounters (!counters, lns) 308 | in 309 | case (grpHdrs, lns) 310 | of (true, []) => lns' 311 | | (true, _) => if fullNames 312 | then (grpFullName grp, itos(total grp)) :: lns @ lns' 313 | else (name, itos(total grp)) :: lns @ lns' 314 | | _ => lns @ lns' 315 | (* end case *) 316 | end 317 | val lns = getLines (grp, []) 318 | (* compute maximum widths *) 319 | val (max1, max2) = List.foldl 320 | (fn ((s1, s2), (m1, m2)) => 321 | (Int.max(size s1, m1), Int.max(size s2, m2))) 322 | (0, 0) 323 | lns 324 | (* the right padding for the name *) 325 | val pad1 = StringCvt.padRight sepChr (max1 + 1) 326 | fun fmt1 name = pad1 (name ^ " ") 327 | (* the left padding for the value *) 328 | val pad2 = StringCvt.padLeft sepChr (max2 + 1) 329 | fun fmt2 value = pad2 (" " ^ value) 330 | (* the minimum seperator is " .... " *) 331 | val sepWid = Int.max (6, wid - size prefix - max1 - max2) 332 | val sep = CharVector.tabulate (sepWid - 2, Fn.const sepChr) 333 | (* print a line of the report *) 334 | fun prLn (name, value) = TextIO.output(outS, String.concat[ 335 | prefix, fmt1 name, sep, fmt2 value, "\n" 336 | ]) 337 | in 338 | List.app prLn lns 339 | end 340 | 341 | val report = fmtReport { 342 | prefix="", wid = 72, sepChr = #".", 343 | noZeros=true, grpHdrs=false, fullNames=true 344 | } 345 | 346 | fun toJSON grp = let 347 | fun intToJSON i = JSON.INT(IntInf.fromInt i) 348 | fun priToJSON p = JSON.ARRAY(List.map intToJSON p) 349 | fun grpToJSON (G{pri, kids, counters, ...}) = let 350 | val fields = List.foldr 351 | (fn (C{name, cnt, ...}, flds) => (name, intToJSON(!cnt)) :: flds) 352 | [] (!counters) 353 | val fields = List.foldr 354 | (fn (g, flds) => (name g, grpToJSON g) :: flds) 355 | fields 356 | (sort (List.filter (not o hidden) (!kids))) 357 | val fields = ("priority", priToJSON pri) :: fields 358 | in 359 | JSON.OBJECT fields 360 | end 361 | in 362 | if hidden grp then JSON.NULL else grpToJSON grp 363 | end 364 | 365 | end 366 | 367 | structure Counter = 368 | struct 369 | 370 | type t = counter 371 | 372 | fun new (grp as G{counters, ...}) name = let 373 | val cntr = C{grp = grp, name = name, cnt = ref 0} 374 | in 375 | counters := cntr :: !counters; 376 | cntr 377 | end 378 | 379 | fun name (C{name, ...}) = name 380 | 381 | val fullName = cntrFullName 382 | 383 | fun tick (cntr as C{cnt, ...}) = ( 384 | if !logTicks 385 | then Log.msg ["++ ", fullName cntr, "\n"] 386 | else (); 387 | cnt := !cnt + 1) 388 | 389 | fun bump (C{cnt, ...}, n) = cnt := !cnt + n 390 | 391 | fun value (C{cnt, ...}) = !cnt 392 | 393 | fun reset (C{cnt, ...}) = cnt := 0 394 | 395 | end 396 | 397 | end 398 | -------------------------------------------------------------------------------- /libsrc/Stamps/stamp.sml: -------------------------------------------------------------------------------- 1 | (* stamp.sml 2 | * 3 | * Stamps are locally unique identifiers used in the compiler to 4 | * distinguish different types, variables, etc. For a given compilation, 5 | * the stamp assigned to an object is guaranteed to be unique, although 6 | * an object may have different stamps assigned to it in different compiles. 7 | * 8 | * COPYRIGHT (c) 2016 John Reppy (https://cs.uchicago.edu/~jhr) 9 | * 10 | * Permission is hereby granted, free of charge, to any person obtaining a copy 11 | * of this software and associated documentation files (the "Software"), to deal 12 | * in the Software without restriction, including without limitation the rights 13 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 14 | * copies of the Software, and to permit persons to whom the Software is 15 | * furnished to do so, subject to the following conditions: 16 | * 17 | * The above copyright notice and this permission notice shall be included in all 18 | * copies or substantial portions of the Software. 19 | * 20 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 21 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 22 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 23 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 24 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 26 | * SOFTWARE. 27 | * 28 | * This code is part of the SML Compiler Utilities, which can be found at 29 | * 30 | * https://github.com/JohnReppy/sml-compiler-utils 31 | *) 32 | 33 | structure Stamp :> sig 34 | 35 | type t 36 | 37 | (* a distinguished stamp that will never be generated by `new` *) 38 | val zero : t 39 | 40 | (* generate a new stamp *) 41 | val new : unit -> t 42 | 43 | (* `reset stmp` resets the stamp generator while preserving any stamp 44 | * that was generated upto and including stmp. This function should 45 | * be used with care, since it invalidates the uniqueness invariant of 46 | * any stamps that were generated after `stmp`. Use `reset zero` to 47 | * completely reset the stamp generator. 48 | *) 49 | val reset : t -> unit 50 | 51 | (* stamp equality test *) 52 | val same : (t * t) -> bool 53 | (* compare two stamps *) 54 | val compare : (t * t) -> order 55 | (* hash a stamp *) 56 | val hash : t -> word 57 | 58 | (* string representation of a stamp; this will be a four-digit hex number 59 | * padded with leading zeros. 60 | *) 61 | val toString : t -> string 62 | 63 | (* sets, maps, and hash tables keyed by stamps *) 64 | structure Set : ORD_SET where type Key.ord_key = t 65 | structure Map : ORD_MAP where type Key.ord_key = t 66 | structure Tbl : MONO_HASH_TABLE where type Key.hash_key = t 67 | 68 | end = struct 69 | 70 | structure W = Word 71 | 72 | datatype t = STAMP of { 73 | id : Word.word 74 | } 75 | 76 | val zero = STAMP{id=0w0} 77 | 78 | val cnt = ref 0w1 79 | 80 | fun new () = let val w = !cnt in cnt := w+0w1; STAMP{id = w} end 81 | 82 | fun reset (STAMP{id}) = cnt := id 83 | 84 | fun same (STAMP{id, ...}, STAMP{id=id', ...}) = (id = id') 85 | fun compare (STAMP{id, ...}, STAMP{id=id', ...}) = W.compare(id, id') 86 | fun hash (STAMP{id, ...}) = id 87 | 88 | fun toString (STAMP{id, ...}) = StringCvt.padLeft #"0" 4 (W.toString id) 89 | 90 | structure Key = 91 | struct 92 | type ord_key = t 93 | val compare = compare 94 | end 95 | structure Map = RedBlackMapFn (Key) 96 | structure Set = RedBlackSetFn (Key) 97 | 98 | structure Tbl = HashTableFn (struct 99 | type hash_key = t 100 | fun hashVal (STAMP{id}) = id 101 | fun sameKey (STAMP{id=a}, STAMP{id=b}) = (a = b) 102 | end) 103 | 104 | end 105 | -------------------------------------------------------------------------------- /tools/MakeFragments/README.md: -------------------------------------------------------------------------------- 1 | ## Compiler Utilities: Make Fragments 2 | 3 | This directory contains the implementation of a tool for converting 4 | source-code fragments contained in source files to string literals 5 | in an SML structure that are suitable for use by the 6 | [code templates](../../libsrc/CodeTemplates/README.md) library. 7 | 8 | ### Usage 9 | 10 | Program to generate a file `"fragments.sml"` containing a fragments structure 11 | from a `CATALOG` file. A `CATALOG` file has the following layout 12 | 13 | 14 | 15 | 16 | ... 17 | 18 | 19 | The resulting file (named `fragments.sml`) will contain a structure with the given 20 | name; the structure consists of named fragments. Two kinds of input files are 21 | supported. If the input file has a `".in"` suffix, then it is converted to an 22 | SML literal string in the output file. If it has a `".json"` suffix, then it 23 | is parsed as a JSON value (see the SML/NJ JSON library) and the resulting 24 | value in the output will be SML code that defines the corresponding `JSON.value` 25 | value. 26 | 27 | ### Wrapper scripts 28 | 29 | When in a compiler, I typically wrap the SML program with scripts that run 30 | the `MkFrags.mkFragments` and `MkFrags.mkMakefile` functions with the appropriate 31 | arguments. When using SML/NJ, I just compile the program each time I run it 32 | as follows: 33 | 34 | ````sh 35 | #!/bin/sh 36 | # 37 | # wrapper script for MkFrags.mkFragments function 38 | # 39 | 40 | PROG=mkfrags 41 | 42 | if [ $# != 1 ] ; then 43 | echo "usage: $PROG.sh " 44 | exit 1 45 | fi 46 | 47 | DIR=$1 48 | 49 | SRC=/path/to/make/fragments/source/sources.cm 50 | 51 | sml $SRC 2> /dev/null 1>/dev/null < MkFrags.mkMakefile dir 35 | | "mkfrags" => MkFrags.mkFragments dir 36 | | _ => fail() 37 | (* end case *)) 38 | | main _ = fail(); 39 | 40 | val _ = main (CommandLine.name(), CommandLine.arguments()) handle _ => fail(); 41 | -------------------------------------------------------------------------------- /tools/MakeFragments/mkfrags.sml: -------------------------------------------------------------------------------- 1 | (* mkfrags.sml 2 | * 3 | * Program to generate a file "fragments.sml" containing a fragments structure 4 | * from a CATALOG file. A CATALOG file has the following layout 5 | * 6 | * 7 | * 8 | * 9 | * ... 10 | * 11 | * 12 | * The resulting file (named fragments.sml) will contain a structure with the given 13 | * name; the structure consists of named fragments. Two kinds of input files are 14 | * supported. If the input file has a ".in" suffix, then it is converted to an 15 | * SML literal string in the output file. If it has a ".json" suffix, then it 16 | * is parsed as a JSON value (see the SML/NJ JSON library) and the resulting 17 | * value in the output will be SML code that defines the corresponding JSON.value 18 | * value. 19 | * 20 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 21 | * 22 | * Permission is hereby granted, free of charge, to any person obtaining a copy 23 | * of this software and associated documentation files (the "Software"), to deal 24 | * in the Software without restriction, including without limitation the rights 25 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 26 | * copies of the Software, and to permit persons to whom the Software is 27 | * furnished to do so, subject to the following conditions: 28 | * 29 | * The above copyright notice and this permission notice shall be included in all 30 | * copies or substantial portions of the Software. 31 | * 32 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 33 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 34 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 35 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 36 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 37 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 38 | * SOFTWARE. 39 | * 40 | * This code is part of the SML Compiler Utilities, which can be found at 41 | * 42 | * https://github.com/JohnReppy/sml-compiler-utils 43 | *) 44 | 45 | structure MkFrags : sig 46 | 47 | (* `mkFragments dir` generates the file `dir/fragments.sml` using the catalog 48 | * file `dir/fragments/CATALOG`. 49 | *) 50 | val mkFragments : string -> unit 51 | 52 | (* `mkMakefile dir` generates the file `dir/fragments.gmk` using the catalog 53 | * file `dir/fragments/CATALOG`. 54 | *) 55 | val mkMakefile : string -> unit 56 | 57 | end = struct 58 | 59 | structure F = Format 60 | structure J = JSON 61 | 62 | (* load the catalog from the file *) 63 | fun loadCatalog file = let 64 | val inS = TextIO.openIn file 65 | (* report a bogus input line *) 66 | fun error (lnum, ln) = raise Fail (concat[ 67 | "[", file, ":", Int.toString lnum, "] bogus input: \"", 68 | String.toString ln, "\"" 69 | ]) 70 | (* get the structure name *) 71 | val structName = (case TextIO.inputLine inS 72 | of NONE => raise Fail "empty CATALOG file" 73 | | SOME ln => (case String.tokens Char.isSpace ln 74 | of [name] => name 75 | | _ => error (1, ln) 76 | (* end case *)) 77 | (* end case *)) 78 | fun lp (lnum, l) = (case TextIO.inputLine inS 79 | of NONE => List.rev l 80 | | SOME ln => (case String.tokens Char.isSpace ln 81 | of [] => lp(lnum+1, l) 82 | | s1::sr => if String.isPrefix "#" s1 83 | then lp(lnum+1, l) 84 | else (case sr 85 | of [s2] => lp (lnum+1, (s1, s2) :: l) 86 | | _ => error (lnum, ln) 87 | (* end case *)) 88 | (* end case *)) 89 | (* end case *)) 90 | in 91 | (structName, lp(2, []) before TextIO.closeIn inS) 92 | handle ex => (TextIO.closeIn inS; raise ex) 93 | end 94 | 95 | (* header for the generated SML file *) 96 | val smlHead = "\ 97 | \(* %s\n\ 98 | \ *\n\ 99 | \ * !!! THIS FILE WAS GENERATED; DO NOT EDIT !!!\n\ 100 | \ *)\n\ 101 | \\n\ 102 | \structure %s =\n\ 103 | \ struct\n\ 104 | \" 105 | 106 | (* footer for the generated SML file *) 107 | val smlFoot = "\ 108 | \\n\ 109 | \ end\n\ 110 | \" 111 | 112 | (* load the contents of an ".in" file *) 113 | fun load srcFile = let 114 | val inS = TextIO.openIn srcFile 115 | fun lp l = (case TextIO.inputLine inS 116 | of NONE => List.rev l 117 | | SOME ln => lp(ln::l) 118 | (* end case *)) 119 | in 120 | (lp [] before TextIO.closeIn inS) 121 | handle ex => (TextIO.closeIn inS; raise ex) 122 | end 123 | 124 | fun doInFile (outS, fragDir) (srcFile, smlVar) = let 125 | val text = load (OS.Path.concat (fragDir, srcFile)) 126 | fun prf (fmt, items) = TextIO.output(outS, F.format fmt items) 127 | in 128 | prf ("\n", []); 129 | prf (" val %s = \"\\\n", [F.STR smlVar]); 130 | prf (" \\/*---------- begin %s ----------*/\\n\\\n", [F.STR srcFile]); 131 | List.app (fn ln => prf(" \\%s\\\n", [F.STR(String.toString ln)])) text; 132 | prf (" \\/*---------- end %s ----------*/\\n\\\n", [F.STR srcFile]); 133 | prf (" \\\"\n", []) 134 | end 135 | 136 | fun doJSONFile (outS, fragDir) (srcFile, smlVar) = let 137 | val value = JSONParser.parseFile (OS.Path.concat (fragDir, srcFile)) 138 | fun pr s = TextIO.output(outS, s) 139 | fun prf (fmt, items) = pr (F.format fmt items) 140 | fun prValue (indent, jv) = (case jv 141 | of J.OBJECT[] => pr "JSON.OBJECT[]" 142 | | J.OBJECT(fld::flds) => let 143 | fun prFld indent (fld, v) = ( 144 | prf ("%s(\"%s\", ", [ 145 | F.LEFT(indent, F.STR ""), F.STR fld 146 | ]); 147 | prValue (indent, v); 148 | pr ")") 149 | in 150 | prf ("JSON.OBJECT[\n", []); 151 | prFld (indent+4) fld; 152 | List.app (fn fld => (pr ",\n"; prFld (indent+4) fld)) flds; 153 | prf ("\n%s]", [F.LEFT(indent+2, F.STR "")]) 154 | end 155 | | J.ARRAY[] => pr "JSON.ARRAY[]" 156 | | J.ARRAY(v::vs) => ( 157 | prf ("JSON.ARRAY[\n", []); 158 | prValue' (indent+4, v); 159 | List.app (fn v => (pr ",\n"; prValue' (indent+4, v))) vs; 160 | prf ("\n%s]", [F.LEFT(indent+2, F.STR "")])) 161 | | J.NULL => pr "JSON.NULL" 162 | | J.BOOL b => prf ("JSON.BOOL %b", [F.BOOL b]) 163 | | J.INT n => prf ("JSON.INT %s", [F.STR(IntInf.toString n)]) 164 | | J.FLOAT f => prf ("JSON.REAL %s", [F.STR(Real.toString f)]) 165 | | J.STRING s => prf ("JSON.STRING \"%s\"", [F.STR(String.toString s)]) 166 | (* end case *)) 167 | and prValue' (indent, jv) = ( 168 | prf ("%s", [F.LEFT(indent, F.STR "")]); 169 | prValue (indent, jv)) 170 | in 171 | pr "\n"; 172 | prf (" val %s = ", [F.STR smlVar]); 173 | prValue (16, value); 174 | pr "\n" 175 | end 176 | 177 | fun doFile arg = let 178 | val doInFile = doInFile arg 179 | val doJSONFile = doJSONFile arg 180 | in 181 | fn (srcFile, smlVar) => (case OS.Path.ext srcFile 182 | of SOME "in" => doInFile (srcFile, smlVar) 183 | | SOME "json" => doJSONFile (srcFile, smlVar) 184 | | _ => raise Fail "unexpected/missing file suffix" 185 | (* end case *)) 186 | end 187 | 188 | fun mkFragments dir = let 189 | val fragDir = OS.Path.concat(dir, "fragments") 190 | val catalogFile = OS.Path.concat(fragDir, "CATALOG") 191 | val fragFile = OS.Path.concat(dir, "fragments.sml") 192 | val (structName, catalog) = if OS.FileSys.access(catalogFile, [OS.FileSys.A_READ]) 193 | then loadCatalog catalogFile 194 | else raise Fail(concat["cannot find \"", catalogFile, "\""]) 195 | val outS = TextIO.openOut fragFile 196 | fun prf (fmt, items) = TextIO.output(outS, F.format fmt items) 197 | in 198 | prf (smlHead, [F.STR(OS.Path.file fragFile), F.STR structName]); 199 | List.app (doFile (outS, fragDir)) catalog; 200 | prf (smlFoot, []); 201 | TextIO.closeOut outS 202 | end 203 | 204 | (* header for the generated Makefile file *) 205 | val mkHead = "\ 206 | \# fragments.gmk\n\ 207 | \#\n\ 208 | \# !!! THIS FILE WAS GENERATED; DO NOT EDIT !!!\n\ 209 | \#\n\ 210 | \\n\ 211 | \" 212 | 213 | fun mkMakefile dir = let 214 | val fragDir = OS.Path.concat(dir, "fragments") 215 | val catalogFile = OS.Path.concat(fragDir, "CATALOG") 216 | val makefile = OS.Path.concat(dir, "fragments.gmk") 217 | val (_, catalog) = if OS.FileSys.access(catalogFile, [OS.FileSys.A_READ]) 218 | then loadCatalog catalogFile 219 | else raise Fail(concat["cannot find \"", catalogFile, "\""]) 220 | val outS = TextIO.openOut makefile 221 | fun prf (fmt, items) = TextIO.output(outS, F.format fmt items) 222 | fun prDep file = prf(" \\\n %s/fragments/%s", [F.STR dir, F.STR file]) 223 | in 224 | prf (mkHead, []); 225 | prf ("%s/fragments.sml:", [F.STR dir]); 226 | prDep "CATALOG"; 227 | List.app (fn (srcFile, _) => prDep srcFile) catalog; 228 | prf ("\n", []); 229 | TextIO.closeOut outS 230 | end 231 | 232 | end 233 | -------------------------------------------------------------------------------- /tools/MakeFragments/sources.cm: -------------------------------------------------------------------------------- 1 | (* sources.cm 2 | * 3 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 4 | * 5 | * Permission is hereby granted, free of charge, to any person obtaining a copy 6 | * of this software and associated documentation files (the "Software"), to deal 7 | * in the Software without restriction, including without limitation the rights 8 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | * copies of the Software, and to permit persons to whom the Software is 10 | * furnished to do so, subject to the following conditions: 11 | * 12 | * The above copyright notice and this permission notice shall be included in all 13 | * copies or substantial portions of the Software. 14 | * 15 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | * SOFTWARE. 22 | * 23 | * This code is part of the SML Compiler Utilities, which can be found at 24 | * 25 | * https://github.com/JohnReppy/sml-compiler-utils 26 | *) 27 | 28 | Library 29 | 30 | structure MkFrags 31 | 32 | is 33 | 34 | $/basis.cm 35 | $/smlnj-lib.cm 36 | $/json-lib.cm 37 | 38 | mkfrags.sml 39 | -------------------------------------------------------------------------------- /tools/MakeFragments/sources.mlb: -------------------------------------------------------------------------------- 1 | (* sources.mlb 2 | * 3 | * MLB for the fragment generators using MLton 4 | * 5 | * COPYRIGHT (c) 2017 John Reppy (https://cs.uchicago.edu/~jhr) 6 | * 7 | * Permission is hereby granted, free of charge, to any person obtaining a copy 8 | * of this software and associated documentation files (the "Software"), to deal 9 | * in the Software without restriction, including without limitation the rights 10 | * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | * copies of the Software, and to permit persons to whom the Software is 12 | * furnished to do so, subject to the following conditions: 13 | * 14 | * The above copyright notice and this permission notice shall be included in all 15 | * copies or substantial portions of the Software. 16 | * 17 | * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | * SOFTWARE. 24 | * 25 | * This code is part of the SML Compiler Utilities, which can be found at 26 | * 27 | * https://github.com/JohnReppy/sml-compiler-utils 28 | *) 29 | 30 | $(SML_LIB)/basis/basis.mlb 31 | $(SML_LIB)/smlnj-lib/Util/smlnj-lib.mlb 32 | $(SML_LIB)/smlnj-lib/JSON/json-lib.mlb 33 | 34 | mkfrags.sml 35 | main.sml 36 | --------------------------------------------------------------------------------