1 #!/usr/bin/env runhaskell
   2 
   3 {-
   4 /*
   5  * Copyright (c) 2011, 2013, Oracle and/or its affiliates. All rights reserved.
   6  * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   7  *
   8  * This code is free software; you can redistribute it and/or modify it
   9  * under the terms of the GNU General Public License version 2 only, as
  10  * published by the Free Software Foundation.  Oracle designates this
  11  * particular file as subject to the "Classpath" exception as provided
  12  * by Oracle in the LICENSE file that accompanied this code.
  13  *
  14  * This code is distributed in the hope that it will be useful, but WITHOUT
  15  * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16  * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17  * version 2 for more details (a copy is included in the LICENSE file that
  18  * accompanied this code).
  19  *
  20  * You should have received a copy of the GNU General Public License version
  21  * 2 along with this work; if not, write to the Free Software Foundation,
  22  * Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA.
  23  *
  24  * Please contact Oracle, 500 Oracle Parkway, Redwood Shores, CA 94065 USA
  25  * or visit www.oracle.com if you need additional information or have any
  26  * questions.
  27  */
  28 -}
  29 {-
  30 The simplest way to get Haskell is through MacPorts: sudo port install ghc
  31 
  32 Otherwise, see http://www.haskell.org/ghc/
  33 -}
  34 
  35 import Data.List
  36 import Data.Maybe
  37 import Data.Char
  38 
  39 data Width = W32 | W64
  40              deriving (Show, Eq, Bounded, Enum)
  41 
  42 data NType = NBOOL | Nschar | Nuchar | Nsshort | Nushort | Nsint | Nuint
  43            | Nslong | Nulong | Nslonglong | Nulonglong | Nfloat | Ndouble
  44              deriving (Show, Eq, Bounded, Enum)
  45 
  46 data JPrim = Jboolean | Jbyte | Jchar | Jshort | Jint | Jlong | Jfloat | Jdouble
  47              deriving (Show, Eq, Bounded, Enum)
  48 
  49 data JClass = JBoolean | JByte | JCharacter | JShort | JInteger | JLong
  50             | JFloat | JDouble
  51               deriving (Show, Eq, Bounded, Enum)
  52 
  53 data FFIType = SINT8 | UINT8 | SINT16 | UINT16 | SINT32 | UINT32
  54              | SINT64 | UINT64 | FLOAT | DOUBLE
  55              deriving (Show, Eq, Bounded, Enum)
  56 
  57 widths = [minBound..maxBound] :: [Width]
  58 ntypes = [minBound..maxBound] :: [NType]
  59 jprims = [minBound..maxBound] :: [JPrim]
  60 jclasses = [minBound..maxBound] :: [JClass]
  61 ffitypes = [minBound..maxBound] :: [FFIType]
  62 
  63 -- What's the FFIType for a given Width and NType? For example: W32 NBOOL -> SINT8
  64 ffitype :: Width -> NType -> FFIType
  65 ffitype _ NBOOL   = SINT8
  66 ffitype _ Nschar  = SINT8
  67 ffitype _ Nuchar  = UINT8
  68 ffitype _ Nsshort = SINT16
  69 ffitype _ Nushort = UINT16
  70 ffitype _ Nsint   = SINT32
  71 ffitype _ Nuint   = UINT32
  72 ffitype W32 Nslong = SINT32
  73 ffitype W64 Nslong = SINT64
  74 ffitype W32 Nulong = UINT32
  75 ffitype W64 Nulong = UINT64
  76 ffitype _ Nslonglong = SINT64
  77 ffitype _ Nulonglong = UINT64
  78 ffitype _ Nfloat  = FLOAT
  79 ffitype _ Ndouble = DOUBLE
  80 
  81 sizeof :: FFIType -> Int
  82 sizeof SINT8  = 1
  83 sizeof UINT8  = 1
  84 sizeof SINT16 = 2
  85 sizeof UINT16 = 2
  86 sizeof SINT32 = 4
  87 sizeof UINT32 = 4
  88 sizeof SINT64 = 8
  89 sizeof UINT64 = 8
  90 sizeof FLOAT  = 4
  91 sizeof DOUBLE = 8
  92 
  93 -- What's the Obj-C encoding for a given NType? For example: unsigned char -> 'C'
  94 encoding nt = fromJust $ lookup nt $
  95               [(NBOOL, 'B'), (Nschar, 'c'), (Nuchar, 'C'), (Nsshort, 's'),
  96                (Nushort, 'S'), (Nsint, 'i'), (Nuint, 'I'), (Nslong, 'l'),
  97                (Nulong, 'L'), (Nslonglong, 'q'), (Nulonglong, 'Q'),
  98                (Nfloat, 'f'), (Ndouble, 'd')]
  99 
 100 -- What's the JPrim for a given NType? For example: native signed long long -> java long
 101 ntype2jprim nt = fromJust $ lookup nt $
 102                  [(NBOOL, Jboolean), (Nschar, Jbyte), (Nuchar, Jbyte),
 103                   (Nsshort, Jshort), (Nushort, Jshort), (Nsint, Jint), (Nuint, Jint),
 104                   (Nslong, Jlong), (Nulong, Jlong),
 105                   (Nslonglong, Jlong), (Nulonglong, Jlong),
 106                   (Nfloat, Jfloat), (Ndouble, Jdouble)]
 107 
 108 -- What's the JClass for a given JPrim? For example: int -> Integer
 109 jprim2jclass jp = fromJust $ lookup jp $
 110                   [(Jboolean, JBoolean), (Jbyte, JByte), (Jchar, JCharacter),
 111                    (Jshort, JShort), (Jint, JInteger), (Jlong, JLong),
 112                    (Jfloat, JFloat), (Jdouble, JDouble)]
 113 
 114 -- Convert a type to something suitable for Java code. For example: Jboolean -> boolean
 115 ntype2js nt = tail $ show nt
 116 jclass2js t = tail $ show t
 117 jprim2js p = tail $ show p
 118 ffitype2js f = "FFI_" ++ (show f)
 119 
 120 -- Capitalize the first letter of a String
 121 capitalize [] = []
 122 capitalize s = [toUpper $ head s] ++ tail s
 123 
 124 -- Given an Width and NType, return the Java code for reading said NType from memory.
 125 popAddr :: Width -> NType -> String
 126 popAddr _ NBOOL   = "rt.unsafe.getByte(addr) != 0"
 127 popAddr _ Nschar  = "rt.unsafe.getByte(addr)"
 128 popAddr _ Nuchar  = "rt.unsafe.getByte(addr)"
 129 popAddr W32 Nslong = "rt.unsafe.getInt(addr)"
 130 popAddr W32 Nulong = "rt.unsafe.getInt(addr)"
 131 popAddr _ ntype = "rt.unsafe.get" ++ (capitalize.jprim2js.ntype2jprim $ ntype) ++ "(addr)"
 132 
 133 -- Given an Width and NType, return the Java code for writing said NType to memory.
 134 pushAddr :: Width -> NType -> String
 135 pushAddr _ NBOOL   = "rt.unsafe.putByte(addr, (byte) (x ? 1 : 0));"
 136 pushAddr _ Nschar  = "rt.unsafe.putByte(addr, x);"
 137 pushAddr _ Nuchar  = "rt.unsafe.putByte(addr, x);"
 138 pushAddr W32 Nslong = "rt.unsafe.putInt(addr, (int) x);"
 139 pushAddr W32 Nulong = "rt.unsafe.putInt(addr, (int) x);"
 140 pushAddr _ ntype = "rt.unsafe.put" ++ (capitalize jprimS) ++ "(addr, (" ++ jprimS ++ ") x);"
 141     where jprimS = jprim2js.ntype2jprim $ ntype
 142 
 143 -- Helpers for generating Java ternarnies and conditionals.
 144 archExpr x32 x64 = if x32 /= x64 then retdiff else x32
 145     where retdiff = "(JObjCRuntime.IS64 ? (" ++ x64 ++ ") : (" ++ x32 ++ "))"
 146 
 147 archStmt x32 x64 = if x32 /= x64 then retdiff else x32
 148     where retdiff = "if(JObjCRuntime.IS64){ " ++ x64 ++ " }else{ " ++ x32 ++ " }"
 149 
 150 -- Get a Java expression for the correct FFIType at runtime. For example: (JObjCRuntime.IS64 ? FFI_SINT64 : FFI_SINT32)
 151 ffitypeVal nt = archExpr (ffitype2js $ ffitype W32 nt)
 152                          (ffitype2js $ ffitype W64 nt)
 153 
 154 -- Similar to ffiTypeVal. Get the correct pop expression and push statement.
 155 popAddrVal nt = archExpr (popAddr W32 nt) (popAddr W64 nt)
 156 pushAddrVal nt = archStmt (pushAddr W32 nt) (pushAddr W64 nt)
 157 
 158 -- What's the Coder class name we're using for a given NType?
 159 coderName nt = aux nt ++ "Coder"
 160     where
 161       aux NBOOL   = "Bool"
 162       aux Nschar  = "SChar"
 163       aux Nuchar  = "UChar"
 164       aux Nsshort = "SShort"
 165       aux Nushort = "UShort"
 166       aux Nsint   = "SInt"
 167       aux Nuint   = "UInt"
 168       aux Nslong  = "SLong"
 169       aux Nulong  = "ULong"
 170       aux Nslonglong   = "SLongLong"
 171       aux Nulonglong   = "ULongLong"
 172       aux Nfloat  = "Float"
 173       aux Ndouble = "Double"
 174 
 175 -- Operation for converting between primitives. Usually it just casts, but booleans are special.
 176 jconvertPrims sym Jboolean Jboolean = sym
 177 jconvertPrims sym Jboolean b = "((" ++ jprim2js b ++ ")(" ++ sym ++ " ? 1 : 0))"
 178 jconvertPrims sym a Jboolean = "(" ++ sym ++ " != 0)"
 179 jconvertPrims sym a b = if a == b then sym else "((" ++ jprim2js b ++ ")" ++ sym ++ ")"
 180 
 181 sizeofRet nt =
 182     let ffitypes = map (\w -> ffitype w nt) widths
 183         sizes = map sizeof ffitypes in
 184     if (length $ nub sizes) == 1
 185     then "\t\treturn " ++ (show.head $ sizes) ++ ";"
 186     else unlines [
 187               "\t\tswitch(w){",
 188               (unlines $ map casestmt widths),
 189               "\t\tdefault: return -1;",
 190                "\t\t}"]
 191     where
 192       casestmt w = "\t\t\tcase " ++ (show w) ++ ": return " ++
 193                    (show.sizeof $ ffitype w nt) ++ ";"
 194 
 195 -- Generate a coder class for a given NType.
 196 c2java ntype =
 197     unlines [
 198  "// native " ++ ntypeS ++ " -> java " ++ jprimS,
 199  "public static final class " ++ className ++ " extends PrimitiveCoder<" ++ jclassS ++ ">{",
 200  "\tpublic static final " ++ className ++ " INST = new " ++ className ++ "();",
 201  "\tpublic " ++ className ++ "(){ super("++ffitypeVal ntype++", \"" ++ [encoding ntype] ++ "\", "++jclassS++".class, "++jprimS++".class); }",
 202  "\t// compile time",
 203  "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){",
 204  "\t\t" ++ pushAddrVal ntype,
 205  "\t}",
 206  "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){",
 207  "\t\treturn " ++ popAddrVal ntype ++ ";",
 208  "\t}",
 209  "\t// for runtime coding",
 210  "\t@Override public int sizeof(Width w){",
 211  sizeofRet ntype,
 212  "\t}",
 213  "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jclassS ++ " x){ " ++
 214  "push(rt, addr, (" ++ jprimS ++ ") x); }",
 215  "\t@Override public " ++ jclassS ++ " pop(JObjCRuntime rt, long addr){ " ++
 216  "return pop" ++ capitalize jprimS ++ "(rt, addr); }",
 217  "\t// proxies for mixed encoding",
 218  makeProxyMethods ntype,
 219  "}"
 220  ]
 221      where
 222        jprim = ntype2jprim ntype
 223        jclass = jprim2jclass jprim
 224        jprimS = jprim2js jprim
 225        jclassS = jclass2js jclass
 226        ntypeS = ntype2js ntype
 227        className = coderName ntype
 228 
 229 -- Generate push and pop methods that convert and proxy to actual implementation.
 230 makeProxyMethods nt = unlines $ map aux jprims
 231     where
 232       targetJPrim = ntype2jprim nt
 233       targetJPrimS = jprim2js targetJPrim
 234       aux jprim = if targetJPrim == jprim then "" else unlines [
 235                    "\t@Override public void push(JObjCRuntime rt, long addr, " ++ jprimS ++ " x){ " ++
 236                    "push(rt, addr, " ++ pushConversion "x" ++ "); }",
 237                    "\t@Override public " ++ jprimS ++ " pop" ++ capitalize jprimS ++ "(JObjCRuntime rt, long addr){ " ++
 238                    "return " ++ (popConversion ("pop" ++ capitalize targetJPrimS ++ "(rt, addr)")) ++ "; }"
 239                   ]
 240           where
 241             jprimS = jprim2js jprim
 242             pushConversion sym = jconvertPrims sym jprim targetJPrim
 243             popConversion sym = jconvertPrims sym targetJPrim jprim
 244 
 245 main = do
 246   putStrLn "package com.apple.jobjc;"
 247 
 248   putStrLn "import com.apple.jobjc.JObjCRuntime.Width;"
 249 
 250   putStrLn "// Auto generated by PrimitiveCoder.hs"
 251   putStrLn "// Do not edit by hand."
 252 
 253   putStrLn "public abstract class PrimitiveCoder<T> extends Coder<T>{"
 254 
 255   putStrLn "\tpublic PrimitiveCoder(int ffiTypeCode, String objCEncoding, Class jclass, Class jprim){"
 256   putStrLn "\t\tsuper(ffiTypeCode, objCEncoding, jclass, jprim);"
 257   putStrLn "\t}"
 258 
 259   mapM_ (\p -> putStrLn $ unlines [makePopI p, makePushI p]) jprims
 260 
 261   mapM_ (putStrLn . c2java) ntypes
 262 
 263   putStrLn "}"
 264     where
 265       makePopI jprim = unlines ["\tpublic final " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim)
 266                                    ++ "(NativeArgumentBuffer args){\n"
 267                                    ++ "\t\treturn pop" ++ (capitalize.jprim2js $ jprim) ++ "(args.runtime, args.retValPtr);\n"
 268                                    ++ "\t}",
 269                                 "\tpublic abstract " ++ jprim2js jprim ++ " pop" ++ (capitalize.jprim2js $ jprim) ++ "(JObjCRuntime runtime, long addr);"]
 270       makePushI jprim = unlines ["\tpublic final void push"
 271           ++ "(NativeArgumentBuffer args, " ++ jprim2js jprim ++ " x){\n"
 272           ++ "\t\tpush(args.runtime, args.argValuesPtr, x);\n"
 273           ++ "\t\targs.didPutArgValue(sizeof());\n"
 274           ++ "\t}",
 275         "\tpublic abstract void push(JObjCRuntime runtime, long addr, " ++ jprim2js jprim ++ " x);"]