Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor LookupConstant (S: LOOKUP_CONSTANT_STRUCTS): LOOKUP_CONSTANT = | |
11 | struct | |
12 | ||
13 | open S | |
14 | local | |
15 | open Const | |
16 | in | |
17 | structure RealX = RealX | |
18 | structure WordX = WordX | |
19 | end | |
20 | structure WordSize = WordX.WordSize | |
21 | ||
22 | val buildConstants: (string * (unit -> string)) list = | |
23 | let | |
24 | val bool = Bool.toString | |
25 | val int = Int.toString | |
26 | open Control | |
27 | in | |
28 | [("MLton_Align_align", fn () => int (case !align of | |
29 | Align4 => 4 | |
30 | | Align8 => 8)), | |
31 | ("MLton_Codegen_codegen", fn () => int (case !codegen of | |
32 | CCodegen => 0 | |
33 | | X86Codegen => 1 | |
34 | | AMD64Codegen => 2 | |
35 | | LLVMCodegen => 3)), | |
36 | ("MLton_FFI_numExports", fn () => int (Ffi.numExports ())), | |
37 | ("MLton_Platform_Format", fn () => case !format of | |
38 | Archive => "archive" | |
39 | | Executable => "executable" | |
40 | | LibArchive => "libarchive" | |
41 | | Library => "library"), | |
42 | ("MLton_Profile_isOn", fn () => bool (case !profile of | |
43 | ProfileNone => false | |
44 | | ProfileCallStack => false | |
45 | | ProfileDrop => false | |
46 | | ProfileLabel => false | |
47 | | _ => true))] | |
48 | end | |
49 | ||
50 | datatype z = datatype ConstType.t | |
51 | ||
52 | val gcFields = | |
53 | [ | |
54 | "atomicState", | |
55 | "currentThread", | |
56 | "sourceMaps.curSourceSeqsIndex", | |
57 | "exnStack", | |
58 | "frontier", | |
59 | "generationalMaps.cardMapAbsolute", | |
60 | "limit", | |
61 | "limitPlusSlop", | |
62 | "maxFrameSize", | |
63 | "signalsInfo.signalIsPending", | |
64 | "stackBottom", | |
65 | "stackLimit", | |
66 | "stackTop" | |
67 | ] | |
68 | ||
69 | val gcFieldsOffsets = | |
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}) | |
75 | val gcFieldsSizes = | |
76 | List.map (gcFields, fn s => | |
77 | {name = s ^ "_Size", | |
78 | value = concat ["(", Ffi.CType.toString Ffi.CType.Word32 ,")", | |
79 | "(sizeof (gcState.", s, "))"], | |
80 | ty = ConstType.Word WordSize.word32}) | |
81 | ||
82 | fun build (constants, out) = | |
83 | let | |
84 | val constants = | |
85 | List.fold | |
86 | (constants, gcFieldsSizes @ gcFieldsOffsets, fn ((name, ty), ac) => | |
87 | if List.exists (buildConstants, fn (name', _) => name = name') | |
88 | then ac | |
89 | else {name = name, value = name, ty = ty} :: ac) | |
90 | in | |
91 | List.foreach | |
92 | (List.concat | |
93 | [["#define MLTON_GC_INTERNAL_TYPES", | |
94 | "#include \"platform.h\"", | |
95 | "struct GC_state gcState;", | |
96 | "", | |
97 | "int main (int argc, char **argv) {"], | |
98 | List.revMap | |
99 | (constants, fn {name, value, ty} => | |
100 | let | |
101 | val (format, value) = | |
102 | case ty of | |
103 | Bool => ("%s", concat [value, "? \"true\" : \"false\""]) | |
104 | | Real _ => ("%.20f", value) | |
105 | | String => ("%s", value) | |
106 | | Word ws => | |
107 | (case WordSize.prim (WordSize.roundUpToPrim ws) of | |
108 | WordSize.W8 => "%\"PRIu8\"" | |
109 | | WordSize.W16 => "%\"PRIu16\"" | |
110 | | WordSize.W32 => "%\"PRIu32\"" | |
111 | | WordSize.W64 => "%\"PRIu64\"", | |
112 | value) | |
113 | in | |
114 | concat ["fprintf (stdout, \"", name, " = ", format, "\\n\", ", | |
115 | value, ");"] | |
116 | end), | |
117 | ["return 0;}"]], | |
118 | fn l => (Out.output (out, l); Out.newline out)) | |
119 | end | |
120 | ||
121 | fun load (ins: In.t, commandLineConstants) | |
122 | : {default: string option, name: string} * ConstType.t -> Const.t = | |
123 | let | |
124 | val table: {hash: word, name: string, value: string} HashSet.t = | |
125 | HashSet.new {hash = #hash} | |
126 | fun add {name, value} = | |
127 | let | |
128 | val hash = String.hash name | |
129 | val _ = | |
130 | HashSet.lookupOrInsert | |
131 | (table, hash, | |
132 | fn {name = name', ...} => name = name', | |
133 | fn () => {hash = hash, name = name, value = value}) | |
134 | in | |
135 | () | |
136 | end | |
137 | val () = | |
138 | List.foreach (buildConstants, fn (name, f) => | |
139 | add {name = name, value = f ()}) | |
140 | val () = | |
141 | List.foreach | |
142 | (commandLineConstants, fn {name, value} => | |
143 | let | |
144 | in | |
145 | add {name = name, value = value} | |
146 | end) | |
147 | val _ = | |
148 | In.foreachLine | |
149 | (ins, fn l => | |
150 | case String.tokens (l, Char.isSpace) of | |
151 | [name, "=", value] => add {name = name, value = value} | |
152 | | _ => Error.bug | |
153 | (concat ["LookupConstants.load: strange constants line: ", l])) | |
154 | fun lookupConstant ({default, name}, ty: ConstType.t): Const.t = | |
155 | let | |
156 | val {value, ...} = | |
157 | let | |
158 | val hash = String.hash name | |
159 | in | |
160 | HashSet.lookupOrInsert | |
161 | (table, hash, | |
162 | fn {name = name', ...} => name = name', | |
163 | fn () => | |
164 | case default of | |
165 | NONE => Error.bug | |
166 | (concat ["LookupConstants.load.lookupConstant: ", | |
167 | "constant not found: ", | |
168 | name]) | |
169 | | SOME value => | |
170 | {hash = hash, | |
171 | name = name, | |
172 | value = value}) | |
173 | end | |
174 | fun error (t: string) = | |
175 | Error.bug (concat ["LookupConstants.load.lookupConstant: ", | |
176 | "constant ", name, " expects a ", t, | |
177 | " but got ", value, "."]) | |
178 | in | |
179 | case ty of | |
180 | Bool => | |
181 | (case Bool.fromString value of | |
182 | NONE => error "bool" | |
183 | | SOME b => Const.Word (WordX.fromIntInf (if b then 1 else 0, WordSize.bool))) | |
184 | | Real rs => | |
185 | (case RealX.make (value, rs) of | |
186 | NONE => error "real" | |
187 | | SOME r => Const.Real r) | |
188 | | String => Const.string value | |
189 | | Word ws => | |
190 | (case IntInf.fromString value of | |
191 | NONE => error "word" | |
192 | | SOME i => Const.Word (WordX.fromIntInf (i, ws))) | |
193 | end | |
194 | in | |
195 | lookupConstant | |
196 | end | |
197 | ||
198 | end |