| 1 | (* Copyright (C) 2015 Matthew Fluet. |
| 2 | * Copyright (C) 2003-2007 Henry Cejtin, Matthew Fluet, Suresh |
| 3 | * Jagannathan, and Stephen Weeks. |
| 4 | * |
| 5 | * MLton is released under a BSD-style license. |
| 6 | * See the file MLton-LICENSE for details. |
| 7 | *) |
| 8 | |
| 9 | functor CFunction (S: C_FUNCTION_STRUCTS): C_FUNCTION = |
| 10 | struct |
| 11 | |
| 12 | open S |
| 13 | |
| 14 | structure Convention = |
| 15 | struct |
| 16 | datatype t = |
| 17 | Cdecl |
| 18 | | Stdcall |
| 19 | |
| 20 | val toString = |
| 21 | fn Cdecl => "cdecl" |
| 22 | | Stdcall => "stdcall" |
| 23 | |
| 24 | val layout = Layout.str o toString |
| 25 | end |
| 26 | |
| 27 | structure Kind = |
| 28 | struct |
| 29 | datatype t = |
| 30 | Impure |
| 31 | | Pure |
| 32 | | Runtime of {bytesNeeded: int option, |
| 33 | ensuresBytesFree: bool, |
| 34 | mayGC: bool, |
| 35 | maySwitchThreads: bool, |
| 36 | modifiesFrontier: bool, |
| 37 | readsStackTop: bool, |
| 38 | writesStackTop: bool} |
| 39 | |
| 40 | val runtimeDefault = Runtime {bytesNeeded = NONE, |
| 41 | ensuresBytesFree = false, |
| 42 | mayGC = true, |
| 43 | maySwitchThreads = false, |
| 44 | modifiesFrontier = true, |
| 45 | readsStackTop = true, |
| 46 | writesStackTop = true} |
| 47 | val pure = Pure |
| 48 | val impure = Impure |
| 49 | val reentrant = runtimeDefault |
| 50 | |
| 51 | fun layout k = |
| 52 | case k of |
| 53 | Impure => Layout.str "Impure" |
| 54 | | Pure => Layout.str "Pure" |
| 55 | | Runtime {bytesNeeded, ensuresBytesFree, mayGC, |
| 56 | maySwitchThreads, modifiesFrontier, |
| 57 | readsStackTop, writesStackTop} => |
| 58 | Layout.namedRecord |
| 59 | ("Runtime", |
| 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)]) |
| 67 | |
| 68 | val toString = Layout.toString o layout |
| 69 | |
| 70 | local |
| 71 | fun make (sel, default) k = |
| 72 | case k of |
| 73 | Impure => default |
| 74 | | Pure => default |
| 75 | | Runtime r => sel r |
| 76 | fun makeBool sel = make (sel, false) |
| 77 | fun makeOpt sel = make (sel, NONE) |
| 78 | in |
| 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 |
| 86 | end |
| 87 | end |
| 88 | |
| 89 | structure SymbolScope = |
| 90 | struct |
| 91 | datatype t = |
| 92 | External |
| 93 | | Private |
| 94 | | Public |
| 95 | |
| 96 | val toString = |
| 97 | fn External => "external" |
| 98 | | Private => "private" |
| 99 | | Public => "public" |
| 100 | |
| 101 | val layout = Layout.str o toString |
| 102 | end |
| 103 | |
| 104 | structure Target = |
| 105 | struct |
| 106 | datatype t = |
| 107 | Direct of string |
| 108 | | Indirect |
| 109 | |
| 110 | val toString = |
| 111 | fn Direct name => name |
| 112 | | Indirect => "<*>" |
| 113 | |
| 114 | val layout = Layout.str o toString |
| 115 | |
| 116 | val equals = |
| 117 | fn (Direct name, Direct name') => name = name' |
| 118 | | (Indirect, Indirect) => true |
| 119 | | _ => false |
| 120 | end |
| 121 | datatype z = datatype Target.t |
| 122 | |
| 123 | datatype 'a t = T of {args: 'a vector, |
| 124 | convention: Convention.t, |
| 125 | kind: Kind.t, |
| 126 | prototype: CType.t vector * CType.t option, |
| 127 | return: 'a, |
| 128 | symbolScope: SymbolScope.t, |
| 129 | target: Target.t} |
| 130 | |
| 131 | fun layout (T {args, convention, kind, prototype, return, symbolScope, target, ...}, |
| 132 | layoutType) = |
| 133 | Layout.record |
| 134 | [("args", Vector.layout layoutType args), |
| 135 | ("convention", Convention.layout convention), |
| 136 | ("kind", Kind.layout kind), |
| 137 | ("prototype", (fn (args,ret) => |
| 138 | Layout.record |
| 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)] |
| 144 | |
| 145 | local |
| 146 | fun make f (T r) = f r |
| 147 | fun makeKind f (T r) = f (#kind r) |
| 148 | in |
| 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 |
| 162 | end |
| 163 | (* quell unused warnings *) |
| 164 | val _ = (modifiesFrontier, readsStackTop, writesStackTop) |
| 165 | |
| 166 | fun equals (f, f') = Target.equals (target f, target f') |
| 167 | |
| 168 | fun map (T {args, convention, kind, prototype, return, symbolScope, target}, |
| 169 | f) = |
| 170 | T {args = Vector.map (args, f), |
| 171 | convention = convention, |
| 172 | kind = kind, |
| 173 | prototype = prototype, |
| 174 | return = f return, |
| 175 | symbolScope = symbolScope, |
| 176 | target = target} |
| 177 | |
| 178 | fun isOk (T {kind, return, ...}, |
| 179 | {isUnit}): bool = |
| 180 | (if Kind.maySwitchThreads kind |
| 181 | then Kind.mayGC kind andalso isUnit return |
| 182 | else true) |
| 183 | andalso (if Kind.ensuresBytesFree kind orelse Kind.maySwitchThreads kind |
| 184 | then Kind.mayGC kind |
| 185 | else true) |
| 186 | andalso (if Kind.mayGC kind |
| 187 | then (Kind.modifiesFrontier kind |
| 188 | andalso Kind.readsStackTop kind andalso Kind.writesStackTop kind) |
| 189 | else true) |
| 190 | andalso (not (Kind.writesStackTop kind) orelse Kind.readsStackTop kind) |
| 191 | |
| 192 | fun vanilla {args, name, prototype, return} = |
| 193 | T {args = args, |
| 194 | convention = Convention.Cdecl, |
| 195 | kind = Kind.Impure, |
| 196 | prototype = prototype, |
| 197 | return = return, |
| 198 | symbolScope = SymbolScope.Private, |
| 199 | target = Direct name} |
| 200 | |
| 201 | fun cPrototype (T {convention, prototype = (args, return), symbolScope, target, |
| 202 | ...}) = |
| 203 | let |
| 204 | val convention = |
| 205 | if convention <> Convention.Cdecl |
| 206 | then concat [" __attribute__ ((", |
| 207 | Convention.toString convention, |
| 208 | ")) "] |
| 209 | else " " |
| 210 | val symbolScope = |
| 211 | case symbolScope of |
| 212 | SymbolScope.External => "EXTERNAL " |
| 213 | | SymbolScope.Private => "PRIVATE " |
| 214 | | SymbolScope.Public => "PUBLIC " |
| 215 | val name = |
| 216 | case target of |
| 217 | Direct name => name |
| 218 | | Indirect => Error.bug "CFunction.cPrototype: Indirect" |
| 219 | val c = Counter.new 0 |
| 220 | fun arg t = |
| 221 | concat [CType.toString t, " x", Int.toString (Counter.next c)] |
| 222 | val return = |
| 223 | case return of |
| 224 | NONE => "void" |
| 225 | | SOME t => CType.toString t |
| 226 | in |
| 227 | concat [symbolScope, return, convention, name, |
| 228 | " (", |
| 229 | concat (List.separate (Vector.toListMap (args, arg), ", ")), |
| 230 | ")"] |
| 231 | end |
| 232 | |
| 233 | fun cPointerType (T {convention, prototype = (args, return), ...}) = |
| 234 | let |
| 235 | val attributes = |
| 236 | if convention <> Convention.Cdecl |
| 237 | then concat [" __attribute__ ((", |
| 238 | Convention.toString convention, |
| 239 | ")) "] |
| 240 | else " " |
| 241 | fun arg t = CType.toString t |
| 242 | val return = |
| 243 | case return of |
| 244 | NONE => "void" |
| 245 | | SOME t => CType.toString t |
| 246 | in |
| 247 | concat |
| 248 | ["(", return, attributes, |
| 249 | "(*)(", |
| 250 | concat (List.separate (Vector.toListMap (args, arg), ", ")), |
| 251 | "))"] |
| 252 | end |
| 253 | |
| 254 | end |