runtime/gen/gen-basis-ffi.sml

   1 (* Copyright (C) 2004-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure List =
   9    struct
  10       open List
  11
  12       fun sort f l =
  13          let
  14             fun qsort l =
  15                case l of
  16                   [] => []
  17                 | hd::tl =>
  18                      let
  19                         val (lt,eq,gt) =
  20                            List.foldr
  21                            (fn (x,(lt,eq,gt)) =>
  22                             case f (x,hd) of
  23                                LESS => (x::lt,eq,gt)
  24                              | EQUAL => (lt,x::eq,gt)
  25                              | GREATER => (lt,eq,x::gt))
  26                            ([],[],[])
  27                            tl
  28                         val lt = qsort lt
  29                         val gt = qsort gt
  30                      in
  31                         lt @ (hd :: eq) @ gt
  32                      end
  33          in
  34             qsort l
  35          end
  36    end
  37
  38 structure Substring =
  39    struct
  40       open Substring
  41
  42       fun droplSpace ss =
  43          dropl Char.isSpace ss
  44       fun droprSpace ss =
  45          dropr Char.isSpace ss
  46
  47    end
  48
  49 structure Name =
  50    struct
  51       datatype t = T of string list
  52
  53       fun compare (T ss1, T ss2) =
  54          List.collate
  55          (fn (s1,s2) =>
  56           String.compare (CharVector.map Char.toLower s1,
  57                           CharVector.map Char.toLower s2))
  58          (ss1, ss2)
  59
  60       fun last (T ss) = List.last ss
  61       fun toC (T ss) =
  62          String.concatWith "_" ss
  63       fun toML (T ss) =
  64          String.concatWith "." ss
  65
  66       fun parse ss =
  67          let
  68             val ss = Substring.droplSpace ss
  69             val (names, rest) =
  70                Substring.splitl
  71                (fn c => Char.isAlphaNum c
  72                    orelse c = #"." orelse c = #"_")
  73                ss
  74             val rest = Substring.droplSpace rest
  75          in
  76             if Substring.isEmpty names
  77                then NONE
  78                else let
  79                        val names = Substring.fields (fn c => #"." = c) names
  80                        val names = List.map Substring.string names
  81                     in
  82                        SOME (T names, rest)
  83                     end
  84          end
  85    end
  86
  87
  88 structure Type =
  89    struct
  90       datatype t =
  91          Array of t
  92        | Base of Name.t
  93        | Con of Name.t * t
  94        | Ref of t
  95        | Unit
  96        | Vector of t
  97
  98       fun toC t =
  99          case t of
 100             Array t => concat ["Array(", toC t, ")"]
 101           | Base name => Name.toC name
 102           | Con (name, t) => concat [Name.toC name, "(", toC t, ")"]
 103           | Ref t => concat ["Ref(", toC t, ")"]
 104           | Unit => "void"
 105           | Vector t => concat ["Vector(", toC t, ")"]
 106       fun toML t =
 107          case t of
 108             Array t => concat ["(", toML t, ") array"]
 109           | Base name => Name.toML name
 110           | Con (name, t) => concat ["(", toML t, ") ", Name.toML name]
 111           | Ref t => concat ["(", toML t, ") ref"]
 112           | Unit => "unit"
 113           | Vector t => concat ["(", toML t, ") vector"]
 114
 115       fun parse s =
 116          let
 117             fun loop (s, t) =
 118                case Name.parse s of
 119                   NONE => (t, s)
 120                 | SOME (Name.T ["array"], rest) => loop (rest, Array t)
 121                 | SOME (Name.T ["ref"], rest) => loop (rest, Ref t)
 122                 | SOME (Name.T ["vector"], rest) => loop (rest, Vector t)
 123                 | SOME (name, rest) => loop (rest, Con (name, t))
 124          in
 125             case Name.parse s of
 126                NONE => raise Fail (concat ["Type.parse: \"", Substring.string s, "\""])
 127              | SOME (Name.T ["unit"], rest) => loop (rest, Unit)
 128              | SOME (name, rest) => loop (rest, Base name)
 129          end
 130
 131       fun parseFn s =
 132          let
 133             fun loop (s, args) =
 134                let
 135                   val (arg, rest) = parse s
 136                in
 137                   if Substring.isPrefix "*" rest
 138                      then let
 139                              val rest = #2 (Substring.splitAt (rest, 1))
 140                           in
 141                              loop (rest, arg::args)
 142                           end
 143                   else if Substring.isPrefix "->" rest
 144                      then let
 145                              val rest = #2 (Substring.splitAt (rest, 2))
 146                              val (ret, rest) = parse rest
 147                           in
 148                              ({args = List.rev (arg::args),
 149                                ret = ret},
 150                               rest)
 151                           end
 152                   else raise Fail (concat ["Type.parseFn: \"", Substring.string s, "\""])
 153                end
 154          in
 155             loop (s, [])
 156          end
 157    end
 158
 159 structure Entry =
 160    struct
 161       datatype t =
 162          Const of {name: Name.t,
 163                    ty: Type.t}
 164        | Import of {attrs: string,
 165                     name: Name.t,
 166                     ty: {args: Type.t list,
 167                          ret: Type.t}}
 168        | Symbol of {name: Name.t,
 169                     ty: Type.t}
 170
 171       fun name entry =
 172          case entry of
 173             Const {name,...} => name
 174           | Import {name,...} => name
 175           | Symbol {name,...} => name
 176
 177       fun compare (entry1, entry2) =
 178          Name.compare (name entry1, name entry2)
 179
 180       fun toC entry =
 181          case entry of
 182             Const {name, ty} =>
 183                String.concat
 184                ["PRIVATE extern const ",
 185                 Type.toC ty,
 186                 " ",
 187                 Name.toC name,
 188                 ";"]
 189           | Import {attrs, name, ty = {args, ret}} =>
 190                String.concat
 191                [attrs,
 192                 if String.size attrs > 0 then " " else "",
 193                 Type.toC ret,
 194                 " ",
 195                 Name.toC name,
 196                 "(",
 197                 String.concatWith "," (List.map Type.toC args),
 198                 ");"]
 199           | Symbol {name, ty} =>
 200                String.concat
 201                ["PRIVATE extern ",
 202                 Type.toC ty,
 203                 " ",
 204                 Name.toC name,
 205                 ";"]
 206       fun toML entry =
 207          case entry of
 208             Const {name, ty} =>
 209                String.concat
 210                ["val ",
 211                 Name.last name,
 212                 " = _const \"",
 213                 Name.toC name,
 214                 "\" : ",
 215                 Type.toML ty,
 216                 ";"]
 217           | Import {attrs, name, ty = {args, ret}} =>
 218                String.concat
 219                ["val ",
 220                 Name.last name,
 221                 " = _import \"",
 222                 Name.toC name,
 223                 "\" private : ",
 224                 String.concatWith " * " (List.map Type.toML args),
 225                 " -> ",
 226                 Type.toML ret,
 227                 ";"]
 228           | Symbol {name, ty} =>
 229                String.concat
 230                ["val (",
 231                 Name.last name,
 232                 "Get, ",
 233                 Name.last name,
 234                 "Set) = _symbol \"",
 235                 Name.toC name,
 236                 "\" private : (unit -> (",
 237                 Type.toML ty,
 238                 ")) * ((",
 239                 Type.toML ty,
 240                 ") -> unit);"]
 241
 242       fun parseConst (s, name) =
 243          let
 244             val s = #2 (Substring.splitAt (s, 6))
 245             val s = Substring.droplSpace s
 246             val s = if Substring.isPrefix ":" s
 247                       then #2 (Substring.splitAt (s, 1))
 248                        else raise Fail (concat ["Entry.parseConst: \"", Substring.string s, "\""])
 249             val (ret, rest) = Type.parse s
 250             val () = if Substring.isEmpty rest
 251                         then ()
 252                         else raise Fail (concat ["Entry.parseConst: \"", Substring.string s, "\""])
 253          in
 254             Const {name = name,
 255                    ty = ret}
 256          end
 257
 258       fun parseImport (s, name) =
 259          let
 260             val s = #2 (Substring.splitAt (s, 7))
 261             val s = Substring.droplSpace s
 262             val (attrs, s) =
 263                case CharVectorSlice.findi (fn (_, c) => c = #":") s of
 264                   NONE => raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""])
 265                 | SOME (i, _) => Substring.splitAt (s, i)
 266             val attrs = Substring.droprSpace attrs
 267             val s = if Substring.isPrefix ":" s
 268                        then #2 (Substring.splitAt (s, 1))
 269                        else raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""])
 270             val ({args, ret}, rest) = Type.parseFn s
 271             val () = if Substring.isEmpty rest
 272                         then ()
 273                         else raise Fail (concat ["Entry.parseImport: \"", Substring.string s, "\""])
 274          in
 275             Import {attrs = Substring.string attrs,
 276                     name = name,
 277                     ty = {args = args, ret = ret}}
 278          end
 279
 280       fun parseSymbol (s, name) =
 281          let
 282             val s = #2 (Substring.splitAt (s, 7))
 283             val s = Substring.droplSpace s
 284             val s = if Substring.isPrefix ":" s
 285                       then #2 (Substring.splitAt (s, 1))
 286                        else raise Fail (concat ["Entry.parseSymbol: \"", Substring.string s, "\""])
 287             val (ret, rest) = Type.parse s
 288             val () = if Substring.isEmpty rest
 289                         then ()
 290                         else raise Fail (concat ["Entry.parseSymbol: \"", Substring.string s, "\""])
 291          in
 292             Symbol {name = name,
 293                     ty = ret}
 294          end
 295
 296       fun parse s =
 297          case Name.parse s of
 298             NONE => raise Fail "Entry.parse"
 299           | SOME (name, rest) =>
 300                if Substring.isPrefix "=" rest
 301                   then let
 302                           val rest = #2 (Substring.splitAt (rest, 1))
 303                           val rest = Substring.droplSpace rest
 304                        in
 305                           if Substring.isPrefix "_const" rest
 306                              then parseConst (rest, name)
 307                           else if Substring.isPrefix "_import" rest
 308                              then parseImport (rest, name)
 309                           else if Substring.isPrefix "_symbol" rest
 310                              then parseSymbol (rest, name)
 311                           else raise Fail (concat ["Entry.parse: \"", Substring.string s, "\""])
 312                        end
 313                   else raise Fail (concat ["Entry.parse: \"", Substring.string s, "\""])
 314    end
 315
 316 val entries =
 317    let
 318       val f = TextIO.openIn "basis-ffi.def"
 319       fun loop entries =
 320          case TextIO.inputLine f of
 321             NONE => List.rev entries
 322           | SOME s =>
 323                if String.isPrefix "#" s
 324                   then loop entries
 325                   else let
 326                           val entry = Entry.parse (Substring.full s)
 327                        in
 328                           loop (entry :: entries)
 329                        end
 330       val entries = loop []
 331       val () = TextIO.closeIn f
 332       val entries = List.sort Entry.compare entries
 333    in
 334       entries
 335    end
 336
 337 fun outputC entries =
 338    let
 339       val f = TextIO.openOut "basis-ffi.h"
 340       fun print s = TextIO.output (f, s)
 341       fun println s = if s <> "" then (print s; print "\n") else ()
 342
 343       val () = println "/* This file is automatically generated.  Do not edit. */\n\n"
 344       val () = println "#ifndef _MLTON_BASIS_FFI_H_\n"
 345       val () = println "#define _MLTON_BASIS_FFI_H_\n"
 346       val () = List.app (fn entry => println (Entry.toC entry)) entries
 347       val () = println "#endif /* _MLTON_BASIS_FFI_H_ */"
 348       val () = TextIO.closeOut f
 349    in
 350       ()
 351    end
 352
 353 fun outputML entries =
 354    let
 355       val f = TextIO.openOut "basis-ffi.sml"
 356       fun print s = TextIO.output (f, s)
 357       fun println s = if s <> "" then (print s; print "\n") else ()
 358
 359       val primStrs =
 360          (List.map (fn n => "Char" ^ n) ["8", "16", "32"]) @
 361          (List.map (fn n => "Int" ^ n) ["8", "16", "32", "64"]) @
 362          (List.map (fn n => "Real" ^ n) ["32", "64"]) @
 363          (List.map (fn n => "Word" ^ n) ["8", "16", "32", "64"])
 364
 365       val () = println "(* This file is automatically generated.  Do not edit. *)\n"
 366       val () = println "local open Primitive in "
 367       val () = println "structure PrimitiveFFI ="
 368       val () = println "struct"
 369       val cur =
 370          List.foldl
 371          (fn (entry, cur) =>
 372           let
 373              val Name.T names = Entry.name entry
 374              val str = List.rev (List.tl (List.rev names))
 375              fun loop (cur, str) =
 376                 case (cur, str) of
 377                    ([], []) => ()
 378                  | ([], str) =>
 379                       List.app (fn s =>
 380                                 (println ("structure " ^ s ^ " = ")
 381                                  ; println "struct"
 382                                  ; if List.exists (fn s' => s = s') primStrs
 383                                       then println ("type t = " ^ s ^ ".t")
 384                                       else ()))
 385                                str
 386                  | (cur, []) =>
 387                       List.app (fn _ => println "end") cur
 388                  | (c::cur,s::str) =>
 389                       if c = s
 390                          then loop (cur, str)
 391                          else (println "end"
 392                                ; loop (cur, s::str))
 393           in
 394              loop (cur, str)
 395              ; println (Entry.toML entry)
 396              ; str
 397           end)
 398          []
 399          entries
 400       val () = List.app (fn _ => println "end") cur
 401       val () = println "end"
 402       val () = println "end"
 403       val () = TextIO.closeOut f
 404    in
 405       ()
 406    end
 407
 408 val () = outputC entries
 409 val () = outputML entries