1 (* Copyright (C) 2010-2011,2013-2014 Matthew Fluet.
2 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor LookupConstant (S: LOOKUP_CONSTANT_STRUCTS): LOOKUP_CONSTANT =
17 structure RealX = RealX
18 structure WordX = WordX
20 structure WordSize = WordX.WordSize
22 val buildConstants: (string * (unit -> string)) list =
24 val bool = Bool.toString
25 val int = Int.toString
28 [("MLton_Align_align", fn () => int (case !align of
31 ("MLton_Codegen_codegen", fn () => int (case !codegen of
36 ("MLton_FFI_numExports", fn () => int (Ffi.numExports ())),
37 ("MLton_Platform_Format", fn () => case !format of
39 | Executable => "executable"
40 | LibArchive => "libarchive"
41 | Library => "library"),
42 ("MLton_Profile_isOn", fn () => bool (case !profile of
44 | ProfileCallStack => false
45 | ProfileDrop => false
46 | ProfileLabel => false
50 datatype z = datatype ConstType.t
56 "sourceMaps.curSourceSeqsIndex",
59 "generationalMaps.cardMapAbsolute",
63 "signalsInfo.signalIsPending",
70 List.map (gcFields, fn s =>
71 {name = s ^ "_Offset",
72 value = concat ["(", Ffi.CType.toString Ffi.CType.Word32 ,")",
73 "(offsetof (struct GC_state, ", s, "))"],
74 ty = ConstType.Word WordSize.word32})
76 List.map (gcFields, fn s =>
78 value = concat ["(", Ffi.CType.toString Ffi.CType.Word32 ,")",
79 "(sizeof (gcState.", s, "))"],
80 ty = ConstType.Word WordSize.word32})
82 fun build (constants, out) =
86 (constants, gcFieldsSizes @ gcFieldsOffsets, fn ((name, ty), ac) =>
87 if List.exists (buildConstants, fn (name', _) => name = name')
89 else {name = name, value = name, ty = ty} :: ac)
93 [["#define MLTON_GC_INTERNAL_TYPES",
94 "#include \"platform.h\"",
95 "struct GC_state gcState;",
97 "int main (int argc, char **argv) {"],
99 (constants, fn {name, value, ty} =>
101 val (format, value) =
103 Bool => ("%s", concat [value, "? \"true\" : \"false\""])
104 | Real _ => ("%.20f", value)
105 | String => ("%s", value)
107 (case WordSize.prim (WordSize.roundUpToPrim ws) of
108 WordSize.W8 => "%\"PRIu8\""
109 | WordSize.W16 => "%\"PRIu16\""
110 | WordSize.W32 => "%\"PRIu32\""
111 | WordSize.W64 => "%\"PRIu64\"",
114 concat ["fprintf (stdout, \"", name, " = ", format, "\\n\", ",
118 fn l => (Out.output (out, l); Out.newline out))
121 fun load (ins: In.t, commandLineConstants)
122 : {default: string option, name: string} * ConstType.t -> Const.t =
124 val table: {hash: word, name: string, value: string} HashSet.t =
125 HashSet.new {hash = #hash}
126 fun add {name, value} =
128 val hash = String.hash name
130 HashSet.lookupOrInsert
132 fn {name = name', ...} => name = name',
133 fn () => {hash = hash, name = name, value = value})
138 List.foreach (buildConstants, fn (name, f) =>
139 add {name = name, value = f ()})
142 (commandLineConstants, fn {name, value} =>
145 add {name = name, value = value}
150 case String.tokens (l, Char.isSpace) of
151 [name, "=", value] => add {name = name, value = value}
153 (concat ["LookupConstants.load: strange constants line: ", l]))
154 fun lookupConstant ({default, name}, ty: ConstType.t): Const.t =
158 val hash = String.hash name
160 HashSet.lookupOrInsert
162 fn {name = name', ...} => name = name',
166 (concat ["LookupConstants.load.lookupConstant: ",
167 "constant not found: ",
174 fun error (t: string) =
175 Error.bug (concat ["LookupConstants.load.lookupConstant: ",
176 "constant ", name, " expects a ", t,
177 " but got ", value, "."])
181 (case Bool.fromString value of
183 | SOME b => Const.Word (WordX.fromIntInf (if b then 1 else 0, WordSize.bool)))
185 (case RealX.make (value, rs) of
187 | SOME r => Const.Real r)
188 | String => Const.string value
190 (case IntInf.fromString value of
192 | SOME i => Const.Word (WordX.fromIntInf (i, ws)))