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);"]