1 (* Copyright (C) 2015 Matthew Fluet.
2 * Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor CFunction (S: C_FUNCTION_STRUCTS): C_FUNCTION =
14 structure Convention =
22 | Stdcall => "stdcall"
24 val layout = Layout.str o toString
32 | Runtime of {bytesNeeded: int option,
33 ensuresBytesFree: bool,
35 maySwitchThreads: bool,
36 modifiesFrontier: bool,
40 val runtimeDefault = Runtime {bytesNeeded = NONE,
41 ensuresBytesFree = false,
43 maySwitchThreads = false,
44 modifiesFrontier = true,
46 writesStackTop = true}
49 val reentrant = runtimeDefault
53 Impure => Layout.str "Impure"
54 | Pure => Layout.str "Pure"
55 | Runtime {bytesNeeded, ensuresBytesFree, mayGC,
56 maySwitchThreads, modifiesFrontier,
57 readsStackTop, writesStackTop} =>
60 [("bytesNeeded", Option.layout Int.layout bytesNeeded),
61 ("ensuresBytesFree", Bool.layout ensuresBytesFree),
62 ("mayGC", Bool.layout mayGC),
63 ("maySwitchThreads", Bool.layout maySwitchThreads),
64 ("modifiesFrontier", Bool.layout modifiesFrontier),
65 ("readsStackTop", Bool.layout readsStackTop),
66 ("writesStackTop", Bool.layout writesStackTop)])
68 val toString = Layout.toString o layout
71 fun make (sel, default) k =
76 fun makeBool sel = make (sel, false)
77 fun makeOpt sel = make (sel, NONE)
79 val bytesNeeded = makeOpt #bytesNeeded
80 val ensuresBytesFree = makeBool #ensuresBytesFree
81 val mayGC = makeBool #mayGC
82 val maySwitchThreads = makeBool #maySwitchThreads
83 val modifiesFrontier = makeBool #modifiesFrontier
84 val readsStackTop = makeBool #readsStackTop
85 val writesStackTop = makeBool #writesStackTop
89 structure SymbolScope =
97 fn External => "external"
98 | Private => "private"
101 val layout = Layout.str o toString
111 fn Direct name => name
114 val layout = Layout.str o toString
117 fn (Direct name, Direct name') => name = name'
118 | (Indirect, Indirect) => true
121 datatype z = datatype Target.t
123 datatype 'a t = T of {args: 'a vector,
124 convention: Convention.t,
126 prototype: CType.t vector * CType.t option,
128 symbolScope: SymbolScope.t,
131 fun layout (T {args, convention, kind, prototype, return, symbolScope, target, ...},
134 [("args", Vector.layout layoutType args),
135 ("convention", Convention.layout convention),
136 ("kind", Kind.layout kind),
137 ("prototype", (fn (args,ret) =>
139 [("args", Vector.layout CType.layout args),
140 ("res", Option.layout CType.layout ret)]) prototype),
141 ("return", layoutType return),
142 ("symbolScope", SymbolScope.layout symbolScope),
143 ("target", Target.layout target)]
146 fun make f (T r) = f r
147 fun makeKind f (T r) = f (#kind r)
149 fun args z = make #args z
150 fun bytesNeeded z = makeKind Kind.bytesNeeded z
151 fun convention z = make #convention z
152 fun ensuresBytesFree z = makeKind Kind.ensuresBytesFree z
153 fun mayGC z = makeKind Kind.mayGC z
154 fun maySwitchThreads z = makeKind Kind.maySwitchThreads z
155 fun modifiesFrontier z = makeKind Kind.modifiesFrontier z
156 fun prototype z = make #prototype z
157 fun readsStackTop z = makeKind Kind.readsStackTop z
158 fun return z = make #return z
159 fun symbolScope z = make #symbolScope z
160 fun target z = make #target z
161 fun writesStackTop z = makeKind Kind.writesStackTop z
163 (* quell unused warnings *)
164 val _ = (modifiesFrontier, readsStackTop, writesStackTop)
166 fun equals (f, f') = Target.equals (target f, target f')
168 fun map (T {args, convention, kind, prototype, return, symbolScope, target},
170 T {args = Vector.map (args, f),
171 convention = convention,
173 prototype = prototype,
175 symbolScope = symbolScope,
178 fun isOk (T {kind, return, ...},
180 (if Kind.maySwitchThreads kind
181 then Kind.mayGC kind andalso isUnit return
183 andalso (if Kind.ensuresBytesFree kind orelse Kind.maySwitchThreads kind
186 andalso (if Kind.mayGC kind
187 then (Kind.modifiesFrontier kind
188 andalso Kind.readsStackTop kind andalso Kind.writesStackTop kind)
190 andalso (not (Kind.writesStackTop kind) orelse Kind.readsStackTop kind)
192 fun vanilla {args, name, prototype, return} =
194 convention = Convention.Cdecl,
196 prototype = prototype,
198 symbolScope = SymbolScope.Private,
199 target = Direct name}
201 fun cPrototype (T {convention, prototype = (args, return), symbolScope, target,
205 if convention <> Convention.Cdecl
206 then concat [" __attribute__ ((",
207 Convention.toString convention,
212 SymbolScope.External => "EXTERNAL "
213 | SymbolScope.Private => "PRIVATE "
214 | SymbolScope.Public => "PUBLIC "
218 | Indirect => Error.bug "CFunction.cPrototype: Indirect"
219 val c = Counter.new 0
221 concat [CType.toString t, " x", Int.toString (Counter.next c)]
225 | SOME t => CType.toString t
227 concat [symbolScope, return, convention, name,
229 concat (List.separate (Vector.toListMap (args, arg), ", ")),
233 fun cPointerType (T {convention, prototype = (args, return), ...}) =
236 if convention <> Convention.Cdecl
237 then concat [" __attribute__ ((",
238 Convention.toString convention,
241 fun arg t = CType.toString t
245 | SOME t => CType.toString t
248 ["(", return, attributes,
250 concat (List.separate (Vector.toListMap (args, arg), ", ")),