diff --git a/.github/workflows/ci-super-linter.yml b/.github/workflows/ci-super-linter.yml index deb667e74..7eaf4f129 100644 --- a/.github/workflows/ci-super-linter.yml +++ b/.github/workflows/ci-super-linter.yml @@ -63,3 +63,4 @@ jobs: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} IGNORE_GENERATED_FILES: true NATURAL_LANGUAGE_CONFIG_FILE: '.textlintrc.yml' + FILTER_REGEX_EXCLUDE: .*Test.java diff --git a/.github/workflows/install.yml b/.github/workflows/install.yml index 05762fded..ecf41db9d 100644 --- a/.github/workflows/install.yml +++ b/.github/workflows/install.yml @@ -12,7 +12,7 @@ on: env: IDRIS2_TESTS_CG: jvm ACTIONS_ALLOW_UNSECURE_COMMANDS: true - PREVIOUS_VERSION: 0.6.0 + PREVIOUS_VERSION: 0.6.0.4 jobs: build: diff --git a/.github/workflows/pre-release.yml b/.github/workflows/pre-release.yml index 7edf642eb..f74935fd6 100644 --- a/.github/workflows/pre-release.yml +++ b/.github/workflows/pre-release.yml @@ -8,7 +8,7 @@ on: env: IDRIS2_TESTS_CG: jvm ACTIONS_ALLOW_UNSECURE_COMMANDS: true - PREVIOUS_VERSION: 0.6.0 + PREVIOUS_VERSION: 0.6.0.4 jobs: pre-release: diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 02522ee8e..4e957c1df 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -14,7 +14,7 @@ on: env: IDRIS2_TESTS_CG: jvm ACTIONS_ALLOW_UNSECURE_COMMANDS: true - PREVIOUS_VERSION: 0.6.0 + PREVIOUS_VERSION: 0.6.0.4 jobs: release: diff --git a/Makefile b/Makefile index 0104d0faf..c82a79111 100644 --- a/Makefile +++ b/Makefile @@ -204,7 +204,7 @@ endif mkdir -p ${PREFIX}/lib/ install support/c/${IDRIS2_SUPPORT} ${PREFIX}/lib mkdir -p ${PREFIX}/bin/${NAME}_app - install ${TARGETDIR}/${NAME}_app/* ${PREFIX}/bin/${NAME}_app + cp -rf ${TARGETDIR}/${NAME}_app ${PREFIX}/bin/ install-support: mkdir -p ${PREFIX}/${NAME_VERSION}/support/docs diff --git a/docs/ffi/calling-java-from-idris.rst b/docs/ffi/calling-java-from-idris.rst index 8fc7d7493..e752c9a03 100644 --- a/docs/ffi/calling-java-from-idris.rst +++ b/docs/ffi/calling-java-from-idris.rst @@ -63,6 +63,33 @@ Foreign specifier for constructors start with ```` which is the JVM name f Similar to method calls, constructors specify argument types and return type. In this case, we invoke a zero-argument constructor returning `java/util/ArrayList`. +Accessing fields +================ + +.. code-block:: idris + + data Point : Type where [external] + + -- Get an instance field + %foreign "jvm:#x(java/awt/Point int),java/awt/Point" + prim_getX : Point -> PrimIO Int + + -- Set an instance field + %foreign "jvm:#=x(java/awt/Point int void),java/awt/Point" + prim_setX : Point -> Int -> PrimIO () + + -- Get a static field + %foreign "jvm:#MAX_VALUE(int),java/lang/Integer" + intMax : Int + + -- Set a static field + %foreign "jvm:#=bar(java/lang/String void),io/github/mmhelloworld/helloworld/Main" + prim_setBar : String -> PrimIO () + + +Field foreign specifiers start with ``#``. To mutate fields, foreign specifier starts with ``#=``. Instance field +accessors will have an additional parameter to pass the instance. + Inheritance =========== @@ -133,8 +160,51 @@ Here is a detailed example showing the hierarchy between Java's ``Collection``, printLn !(size {elemTy=String} list) printLn !(toString list) -Here, we create an `ArrayList` instance and call `get` method from `List` and methods from `Collection` such as -`add` and `size`. We are able to pass `ArrayList` instance to the `List` and `Collection` functions because of -`Inherits` interface instances for `ArrayList`. Another note: In JVM, invoking methods on interface is different from -class methods invocation so the foreign specifiers on interface methods have `i:` prefix for the first parameter that -represents the instance that the methods are called on. +Here, we create an ``ArrayList`` instance and call ``get`` method from ``List`` and methods from ``Collection`` such as +``add`` and ``size``. We are able to pass ``ArrayList`` instance to the ``List`` and ``Collection`` functions because of +``Inherits`` interface instances for ``ArrayList``. Another note: In JVM, invoking methods on interface is different +from class methods invocation so the foreign specifiers on interface methods have ``i:`` prefix for the first parameter +that represents the instance that the methods are called on. + +Class literals +================ + +``classLiteral`` function can be used to get Java's ``Class`` instances for JVM types. + +.. code-block:: console + + Main> :module Java.Lang + Imported module Java.Lang + Main> :t classLiteral + Java.Lang.classLiteral : Class ty + +.. code-block:: idris + + import Java.Lang + + main : IO () + main = do + printLn !(Object.toString $ classLiteral {ty=Int}) + printLn !(Object.toString $ classLiteral {ty=Integer}) + printLn !(Object.toString $ classLiteral {ty=String}) + +The above example prints: + +.. code-block:: console + + "int" + "class java.math.BigInteger" + "class java.lang.String" + +JVM reference equality +====================== +Reference equality should be avoided in Idris but it might be useful to interface with Java, for example, for overriding ``equals`` method in Idris. + +.. code-block:: console + + Main> :module Java.Lang + Imported module Java.Lang + Main> :exec printLn (jvmRefEq "foo" "foo") + True + Main> :exec printLn (jvmRefEq "foo" ("fo" ++ "o")) + False diff --git a/idris-jvm-assembler/pom.xml b/idris-jvm-assembler/pom.xml index 6ab007561..531ea9818 100644 --- a/idris-jvm-assembler/pom.xml +++ b/idris-jvm-assembler/pom.xml @@ -1,5 +1,6 @@ - + io.github.mmhelloworld idris-jvm diff --git a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState.java b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState.java index 1d9ebeb0c..b3ca66209 100644 --- a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState.java +++ b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState.java @@ -6,17 +6,16 @@ import java.io.BufferedInputStream; import java.io.BufferedOutputStream; import java.io.File; -import java.io.FileOutputStream; import java.io.IOException; import java.io.InputStream; import java.io.OutputStream; import java.nio.file.Paths; import java.util.Arrays; -import java.util.Collection; import java.util.HashSet; import java.util.List; import java.util.Map; import java.util.Map.Entry; +import java.util.Optional; import java.util.Properties; import java.util.Set; import java.util.concurrent.ConcurrentHashMap; @@ -29,7 +28,6 @@ import static java.nio.file.Files.newInputStream; import static java.nio.file.Files.newOutputStream; import static java.util.Arrays.asList; -import static java.util.Collections.emptyList; import static java.util.Collections.synchronizedSet; import static java.util.concurrent.TimeUnit.SECONDS; import static java.util.stream.Collectors.toList; @@ -52,18 +50,17 @@ public final class AsmGlobalState { private final Set untypedFunctions; private final Set constructors; private final String programName; + private final Map fcAndDefinitionsByName; private final Map assemblers; - public AsmGlobalState(String programName, Collection trampolinePatterns) { + public AsmGlobalState(String programName, + Map fcAndDefinitionsByName) { this.programName = programName; functions = new ConcurrentHashMap<>(); untypedFunctions = synchronizedSet(new HashSet<>()); constructors = synchronizedSet(new HashSet<>()); assemblers = new ConcurrentHashMap<>(); - } - - public AsmGlobalState(String programName) { - this(programName, emptyList()); + this.fcAndDefinitionsByName = fcAndDefinitionsByName; } public static void copyRuntimeJar(String directory) throws IOException { @@ -80,6 +77,31 @@ public static void copyRuntimeJar(String directory) throws IOException { } } + private static List getJavaOptions() { + String javaOpts = getProperty("JAVA_OPTS", "-Xss8m"); + return asList(javaOpts.split("\\s+")); + } + + private static String getProperty(String propertyName, String defaultValue) { + String value = System.getProperty(propertyName, System.getenv(propertyName)); + return value == null ? defaultValue : value; + } + + private static void copy(InputStream inputStream, OutputStream outputStream) throws IOException { + byte[] buffer = new byte[BUFFER_SIZE]; + while (inputStream.read(buffer) > 0) { + outputStream.write(buffer); + } + outputStream.flush(); + } + + private static String getRuntimeJarName() throws IOException { + ClassLoader classLoader = currentThread().getContextClassLoader(); + Properties properties = new Properties(); + properties.load(classLoader.getResourceAsStream("project.properties")); + return format("idris-jvm-runtime-%s.jar", properties.getProperty("project.version")); + } + public synchronized void addFunction(String name, Object value) { functions.put(name, value); } @@ -128,7 +150,6 @@ public void classCodeEnd(String outputDirectory, String outputFile, String mainC } else { new File(classDirectory).mkdirs(); copyRuntimeJar(classDirectory); - Assembler.createJar(classDirectory, outputFile, mainClassNoSlash); Assembler.createExecutable(normalizedOutputDirectory, outputFile, mainClassNoSlash); } } @@ -150,41 +171,21 @@ public void interpret(String mainClass, String outputDirectory) throws IOExcepti public void writeClass(String className, ClassWriter classWriter, String outputClassFileDir) { File outFile = new File(outputClassFileDir, className + ".class"); new File(outFile.getParent()).mkdirs(); - try (OutputStream out = new FileOutputStream(outFile)) { + try (OutputStream out = newOutputStream(outFile.toPath())) { out.write(classWriter.toByteArray()); } catch (Exception exception) { exception.printStackTrace(); } } - private static List getJavaOptions() { - String javaOpts = getProperty("JAVA_OPTS", "-Xss8m"); - return asList(javaOpts.split("\\s+")); - } - - private static String getProperty(String propertyName, String defaultValue) { - String value = System.getProperty(propertyName, System.getenv(propertyName)); - return value == null ? defaultValue : value; - } - - private static void copy(InputStream inputStream, OutputStream outputStream) throws IOException { - byte[] buffer = new byte[BUFFER_SIZE]; - while (inputStream.read(buffer) > 0) { - outputStream.write(buffer); - } - outputStream.flush(); - } - - private static String getRuntimeJarName() throws IOException { - ClassLoader classLoader = currentThread().getContextClassLoader(); - Properties properties = new Properties(); - properties.load(classLoader.getResourceAsStream("project.properties")); - return format("idris-jvm-runtime-%s.jar", properties.getProperty("project.version")); - } - private Stream> getClassNameAndClassWriters() { return assemblers.values().parallelStream() .map(Assembler::classInitEnd) .flatMap(assembler -> assembler.getClassWriters().entrySet().stream()); } + + public Object getFcAndDefinition(String name) { + return Optional.ofNullable(fcAndDefinitionsByName.get(name)) + .orElseThrow(() -> new IdrisJvmException("Unable to find function " + name)); + } } diff --git a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/Assembler.java b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/Assembler.java index 3b3aeb766..1ad0107b5 100644 --- a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/Assembler.java +++ b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/Assembler.java @@ -116,6 +116,7 @@ import static org.objectweb.asm.Opcodes.IFNE; import static org.objectweb.asm.Opcodes.IFNONNULL; import static org.objectweb.asm.Opcodes.IFNULL; +import static org.objectweb.asm.Opcodes.IF_ACMPNE; import static org.objectweb.asm.Opcodes.IF_ICMPEQ; import static org.objectweb.asm.Opcodes.IF_ICMPGE; import static org.objectweb.asm.Opcodes.IF_ICMPGT; @@ -183,6 +184,11 @@ public final class Assembler { public static final int BUFFER_SIZE = 1024; private static final boolean SHOULD_DEBUG; + static { + String shouldDebug = System.getProperty("IDRIS_JVM_DEBUG", System.getenv("IDRIS_JVM_DEBUG")); + SHOULD_DEBUG = shouldDebug != null && !shouldDebug.isEmpty() && !shouldDebug.equals("false"); + } + private final Map cws; private final Deque classMethodVisitorStack = new LinkedList<>(); private Map env; @@ -193,11 +199,6 @@ public final class Assembler { private String className; private String methodName; - static { - String shouldDebug = System.getProperty("IDRIS_JVM_DEBUG", System.getenv("IDRIS_JVM_DEBUG")); - SHOULD_DEBUG = shouldDebug != null && !shouldDebug.isEmpty() && !shouldDebug.equals("false"); - } - public Assembler() { this.cws = new HashMap<>(); this.env = new HashMap<>(); @@ -221,6 +222,166 @@ public static void createExecutable(String directoryName, String fileName, Strin createWindowsExecutable(directoryName, fileName, mainClass, javaOpts); } + private static void createWindowsExecutable(String directoryName, String fileName, String mainClass, + String javaOpts) throws IOException { + File batExe = new File(directoryName, fileName + ".bat"); + String batHeader = "@echo off"; + String classpath = "%~dp0\\" + fileName + "_app\\*;" + "%~dp0\\" + fileName + "_app"; + String javaCommand = Stream.of("java", "%JAVA_OPTS%", javaOpts, "-cp", classpath, mainClass, "%*") + .filter(Assembler::isNotNullOrEmpty) + .collect(joining(" ")); + Files.write(batExe.toPath(), createExecutableFileContent(batHeader, javaCommand)); + } + + private static void createPosixExecutable(String directoryName, String fileName, String mainClass, + String javaOpts) throws IOException { + File shExe = new File(directoryName, fileName); + String shHeader = "#!/bin/sh"; + String classpath = "\"`dirname $0`/" + fileName + "_app/*" + ":`dirname $0`/" + fileName + "_app\""; + String javaCommand = Stream.of("java", "$JAVA_OPTS", javaOpts, "-cp", classpath, mainClass, "\"$@\"") + .filter(Assembler::isNotNullOrEmpty) + .collect(joining(" ")); + Files.write(shExe.toPath(), createExecutableFileContent(shHeader, javaCommand)); + setPosixFilePermissions(shExe.toPath(), PosixFilePermissions.fromString("rwxr-xr-x")); + } + + private static boolean isNotNullOrEmpty(String value) { + return value != null && !value.isEmpty(); + } + + private static byte[] createExecutableFileContent(String... lines) { + return String.join(lineSeparator(), lines).getBytes(UTF_8); + } + + private static Manifest createManifest(String mainClass) { + Manifest manifest = new Manifest(); + Attributes manifestAttributes = manifest.getMainAttributes(); + manifestAttributes.put(MANIFEST_VERSION, "1.0"); + manifestAttributes.put(MAIN_CLASS, mainClass); + return manifest; + } + + private static void add(File source, JarOutputStream target, File jarFile, File rootDirectory) throws IOException { + if (source.isDirectory()) { + addDirectory(source, target, jarFile, rootDirectory); + } else { + addFile(source, target, jarFile, rootDirectory); + } + if (source.isDirectory() || !source.getName().endsWith(".jar")) { + source.delete(); + } + } + + private static void addFile(File source, JarOutputStream jarOutputStream, File jarFile, File rootDirectory) + throws IOException { + if (source.equals(jarFile)) { + return; + } + JarEntry entry = new JarEntry(getJarEntryName(source, rootDirectory)); + entry.setTime(source.lastModified()); + jarOutputStream.putNextEntry(entry); + try (BufferedInputStream in = new BufferedInputStream(newInputStream(source.toPath()))) { + byte[] buffer = new byte[BUFFER_SIZE]; + while (true) { + int count = in.read(buffer); + if (count == -1) { + break; + } + jarOutputStream.write(buffer, 0, count); + } + jarOutputStream.closeEntry(); + } + } + + private static void addDirectory(File source, JarOutputStream jarOutputStream, File jarFile, File rootDirectory) + throws IOException { + String name = getJarEntryName(source, rootDirectory); + if (!name.isEmpty()) { + createDirectory(name, source.lastModified(), jarOutputStream); + } + File[] files = requireNonNull(source.listFiles(), "Unable to get files from directory " + source); + for (File file : files) { + add(file, jarOutputStream, jarFile, rootDirectory); + } + } + + private static String getJarEntryName(File source, File rootDirectory) { + String name = source.getPath().replace(rootDirectory.getPath(), "").replace("\\", "/"); + return !name.startsWith("/") ? name : name.substring(1); + } + + private static void createDirectory(String name, long lastModified, JarOutputStream jarOutputStream) + throws IOException { + if (!name.endsWith("/")) { + name += "/"; + } + JarEntry entry = new JarEntry(name); + entry.setTime(lastModified); + jarOutputStream.putNextEntry(entry); + jarOutputStream.closeEntry(); + } + + private static Type getType(String typeDescriptor) { + switch (typeDescriptor) { + case "boolean": + return Type.BOOLEAN_TYPE; + case "byte": + return Type.BYTE_TYPE; + case "char": + return Type.CHAR_TYPE; + case "short": + return Type.SHORT_TYPE; + case "int": + return Type.INT_TYPE; + case "long": + return Type.LONG_TYPE; + case "float": + return Type.FLOAT_TYPE; + case "double": + return Type.DOUBLE_TYPE; + case "void": + return Type.VOID_TYPE; + default: + if (typeDescriptor.endsWith("[]")) { + return Type.getObjectType(getArrayDescriptor(typeDescriptor)); + } else { + return Type.getObjectType(typeDescriptor); + } + } + + } + + private static String getArrayDescriptor(String str) { + int stack = 0; + int dimension = 0; + for (int i = str.length() - 1; i >= 0; i--) { + char ch = str.charAt(i); + int delta = ch == ']' ? 1 : (ch == '[' ? -1 : 0); + if (delta == 0) { + if (stack != 0) { + throw new IllegalArgumentException("Invalid array descriptor " + str); + } + return createArrayDescriptor(str.substring(0, i + 1), dimension); + } + stack = stack + delta; + if (stack == 0) { + dimension++; + } else if (stack != 1) { + throw new IllegalArgumentException("Invalid array descriptor " + str); + } + } + throw new IllegalArgumentException("Invalid array descriptor " + str); + } + + private static String createArrayDescriptor(String elementTypeName, int dimension) { + String elementTypeDesc = getType(elementTypeName).getDescriptor(); + StringBuilder arrayDesc = new StringBuilder(); + for (int i = 0; i < dimension; i++) { + arrayDesc.append('['); + } + return arrayDesc + elementTypeDesc; + } + public void endMethod() { mv.visitEnd(); } @@ -353,9 +514,21 @@ public Assembler classInitEnd() { } public void createField(int acc, String sourceFile, String newClassName, String fieldName, String desc, String sig, - Object value) { + Object value, Object annotations) { + createField(acc, sourceFile, newClassName, fieldName, desc, sig, value, (List) annotations); + } + + public void createField(int acc, String sourceFile, String newClassName, String fieldName, String desc, String sig, + Object value, List annotations) { cw = cws.computeIfAbsent(newClassName, cname -> createClassWriter(sourceFile, cname)); fv = cw.visitField(acc, fieldName, desc, sig, value); + + annotations.forEach(annotation -> { + AnnotationVisitor av = fv.visitAnnotation(annotation.getName(), true); + annotation.getProperties().forEach(prop -> visitAnnotationProperty(av, prop.getName(), prop.getValue())); + av.visitEnd(); + }); + } public void createLabel(String labelName) { @@ -779,6 +952,10 @@ public void ificmplt(String label) { mv.visitJumpInsn(IF_ICMPLT, (Label) env.get(label)); } + public void ifacmpne(String label) { + mv.visitJumpInsn(IF_ACMPNE, (Label) env.get(label)); + } + public void ificmpne(String label) { mv.visitJumpInsn(IF_ICMPNE, (Label) env.get(label)); } @@ -1109,166 +1286,6 @@ public void localVariable(String name, String typeDescriptor, String signature, mv.visitLocalVariable(name, typeDescriptor, signature, start, end, index); } - private static void createWindowsExecutable(String directoryName, String fileName, String mainClass, - String javaOpts) throws IOException { - File batExe = new File(directoryName, fileName + ".bat"); - String batHeader = "@echo off"; - String classpath = "%~dp0\\" + fileName + "_app\\*"; - String javaCommand = Stream.of("java", "%JAVA_OPTS%", javaOpts, "-cp", classpath, mainClass, "%*") - .filter(Assembler::isNotNullOrEmpty) - .collect(joining(" ")); - Files.write(batExe.toPath(), createExecutableFileContent(batHeader, javaCommand)); - } - - private static void createPosixExecutable(String directoryName, String fileName, String mainClass, - String javaOpts) throws IOException { - File shExe = new File(directoryName, fileName); - String shHeader = "#!/bin/sh"; - String classpath = "\"`dirname $0`/" + fileName + "_app/*\""; - String javaCommand = Stream.of("java", "$JAVA_OPTS", javaOpts, "-cp", classpath, mainClass, "\"$@\"") - .filter(Assembler::isNotNullOrEmpty) - .collect(joining(" ")); - Files.write(shExe.toPath(), createExecutableFileContent(shHeader, javaCommand)); - setPosixFilePermissions(shExe.toPath(), PosixFilePermissions.fromString("rwxr-xr-x")); - } - - private static boolean isNotNullOrEmpty(String value) { - return value != null && !value.isEmpty(); - } - - private static byte[] createExecutableFileContent(String... lines) { - return String.join(lineSeparator(), lines).getBytes(UTF_8); - } - - private static Manifest createManifest(String mainClass) { - Manifest manifest = new Manifest(); - Attributes manifestAttributes = manifest.getMainAttributes(); - manifestAttributes.put(MANIFEST_VERSION, "1.0"); - manifestAttributes.put(MAIN_CLASS, mainClass); - return manifest; - } - - private static void add(File source, JarOutputStream target, File jarFile, File rootDirectory) throws IOException { - if (source.isDirectory()) { - addDirectory(source, target, jarFile, rootDirectory); - } else { - addFile(source, target, jarFile, rootDirectory); - } - if (source.isDirectory() || !source.getName().endsWith(".jar")) { - source.delete(); - } - } - - private static void addFile(File source, JarOutputStream jarOutputStream, File jarFile, File rootDirectory) - throws IOException { - if (source.equals(jarFile)) { - return; - } - JarEntry entry = new JarEntry(getJarEntryName(source, rootDirectory)); - entry.setTime(source.lastModified()); - jarOutputStream.putNextEntry(entry); - try (BufferedInputStream in = new BufferedInputStream(newInputStream(source.toPath()))) { - byte[] buffer = new byte[BUFFER_SIZE]; - while (true) { - int count = in.read(buffer); - if (count == -1) { - break; - } - jarOutputStream.write(buffer, 0, count); - } - jarOutputStream.closeEntry(); - } - } - - private static void addDirectory(File source, JarOutputStream jarOutputStream, File jarFile, File rootDirectory) - throws IOException { - String name = getJarEntryName(source, rootDirectory); - if (!name.isEmpty()) { - createDirectory(name, source.lastModified(), jarOutputStream); - } - File[] files = requireNonNull(source.listFiles(), "Unable to get files from directory " + source); - for (File file : files) { - add(file, jarOutputStream, jarFile, rootDirectory); - } - } - - private static String getJarEntryName(File source, File rootDirectory) { - String name = source.getPath().replace(rootDirectory.getPath(), "").replace("\\", "/"); - return !name.startsWith("/") ? name : name.substring(1); - } - - private static void createDirectory(String name, long lastModified, JarOutputStream jarOutputStream) - throws IOException { - if (!name.endsWith("/")) { - name += "/"; - } - JarEntry entry = new JarEntry(name); - entry.setTime(lastModified); - jarOutputStream.putNextEntry(entry); - jarOutputStream.closeEntry(); - } - - private static Type getType(String typeDescriptor) { - switch (typeDescriptor) { - case "boolean": - return Type.BOOLEAN_TYPE; - case "byte": - return Type.BYTE_TYPE; - case "char": - return Type.CHAR_TYPE; - case "short": - return Type.SHORT_TYPE; - case "int": - return Type.INT_TYPE; - case "long": - return Type.LONG_TYPE; - case "float": - return Type.FLOAT_TYPE; - case "double": - return Type.DOUBLE_TYPE; - case "void": - return Type.VOID_TYPE; - default: - if (typeDescriptor.endsWith("[]")) { - return Type.getObjectType(getArrayDescriptor(typeDescriptor)); - } else { - return Type.getObjectType(typeDescriptor); - } - } - - } - - private static String getArrayDescriptor(String str) { - int stack = 0; - int dimension = 0; - for (int i = str.length() - 1; i >= 0; i--) { - char ch = str.charAt(i); - int delta = ch == ']' ? 1 : (ch == '[' ? -1 : 0); - if (delta == 0) { - if (stack != 0) { - throw new IllegalArgumentException("Invalid array descriptor " + str); - } - return createArrayDescriptor(str.substring(0, i + 1), dimension); - } - stack = stack + delta; - if (stack == 0) { - dimension++; - } else if (stack != 1) { - throw new IllegalArgumentException("Invalid array descriptor " + str); - } - } - throw new IllegalArgumentException("Invalid array descriptor " + str); - } - - private static String createArrayDescriptor(String elementTypeName, int dimension) { - String elementTypeDesc = getType(elementTypeName).getDescriptor(); - StringBuilder arrayDesc = new StringBuilder(); - for (int i = 0; i < dimension; i++) { - arrayDesc.append('['); - } - return arrayDesc + elementTypeDesc; - } - private ClassWriter createClassWriter(String sourceFile, String cname) { ClassWriter classWriter = new IdrisClassWriter(COMPUTE_MAXS + COMPUTE_FRAMES); classWriter.visit(V1_8, ACC_PUBLIC + ACC_FINAL, cname, null, "java/lang/Object", null); @@ -1297,15 +1314,18 @@ private void handleCreateMethod(MethodVisitor targetMethodVisitor, List parameterAnnotations = parametersAnnotations.get(parameterIndex); - parameterAnnotations.forEach(paramAnnotation -> { - final AnnotationVisitor av = - targetMethodVisitor.visitParameterAnnotation(parameterIndex, paramAnnotation.getName(), true); - paramAnnotation.getProperties().forEach(prop -> visitAnnotationProperty(av, prop.getName(), - prop.getValue())); - av.visitEnd(); - }); + parameterAnnotations.forEach(paramAnnotation -> + addParameterAnnotation(targetMethodVisitor, parameterIndex, paramAnnotation)); } + } + private void addParameterAnnotation(MethodVisitor targetMethodVisitor, int parameterIndex, + Annotation paramAnnotation) { + AnnotationVisitor av = + targetMethodVisitor.visitParameterAnnotation(parameterIndex, paramAnnotation.getName(), true); + paramAnnotation.getProperties().forEach(prop -> visitAnnotationProperty(av, prop.getName(), + prop.getValue())); + av.visitEnd(); } private Object toOpcode(String s) { diff --git a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisJvmException.java b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisJvmException.java new file mode 100644 index 000000000..5673dd898 --- /dev/null +++ b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisJvmException.java @@ -0,0 +1,15 @@ +package io.github.mmhelloworld.idrisjvm.assembler; + +public class IdrisJvmException extends RuntimeException { + public IdrisJvmException(String message) { + super(message); + } + + public IdrisJvmException(String message, Throwable cause) { + super(message, cause); + } + + public IdrisJvmException(Throwable cause) { + super(cause); + } +} diff --git a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisName.java b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisName.java index 8bed198f3..7cba72510 100644 --- a/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisName.java +++ b/idris-jvm-assembler/src/main/java/io/github/mmhelloworld/idrisjvm/assembler/IdrisName.java @@ -96,6 +96,8 @@ private static Entry getClassAndMemberName(String programName, S private static String getClassName(String programName, String idrisNamespace) { if (idrisNamespace.startsWith("io/github/mmhelloworld/idrisjvm")) { return idrisNamespace; + } else if (idrisNamespace.startsWith("nomangle:")) { + return idrisNamespace.substring("nomangle:".length()); } else { LinkedList moduleParts = Stream.of(idrisNamespace.split("/")).collect(toCollection(LinkedList::new)); diff --git a/idris-jvm-assembler/src/test/java/io/github/mmhelloworld/idrisjvm/jvmassembler/IdrisNameTest.java b/idris-jvm-assembler/src/test/java/io/github/mmhelloworld/idrisjvm/jvmassembler/IdrisNameTest.java index 8a9ff9ffe..56719ad7a 100644 --- a/idris-jvm-assembler/src/test/java/io/github/mmhelloworld/idrisjvm/jvmassembler/IdrisNameTest.java +++ b/idris-jvm-assembler/src/test/java/io/github/mmhelloworld/idrisjvm/jvmassembler/IdrisNameTest.java @@ -14,20 +14,6 @@ public final class IdrisNameTest { - @ParameterizedTest - @MethodSource - void getFunctionName(String moduleName, String functionName, IdrisList idrisClassFunctionName) { - assertThat(IdrisName.getIdrisFunctionName("main", moduleName, functionName)) - .isEqualTo(idrisClassFunctionName); - } - - @ParameterizedTest - @MethodSource - void getConstructorClassName(String idrisConstructorName, String transformedConstructorName) { - assertThat(IdrisName.getIdrisConstructorClassName(idrisConstructorName)) - .isEqualTo(transformedConstructorName); - } - static Stream getFunctionName() { return Stream.of( arguments("Data/List", "take", IdrisList.fromIterable(asList("M_Data/List", "take"))), @@ -44,4 +30,18 @@ static Stream getConstructorClassName() { arguments("Prelude", "main/Prelude") ); } + + @ParameterizedTest + @MethodSource + void getFunctionName(String moduleName, String functionName, IdrisList idrisClassFunctionName) { + assertThat(IdrisName.getIdrisFunctionName("main", moduleName, functionName)) + .isEqualTo(idrisClassFunctionName); + } + + @ParameterizedTest + @MethodSource + void getConstructorClassName(String idrisConstructorName, String transformedConstructorName) { + assertThat(IdrisName.getIdrisConstructorClassName(idrisConstructorName)) + .isEqualTo(transformedConstructorName); + } } diff --git a/idris-jvm-compiler/pom.xml b/idris-jvm-compiler/pom.xml index be0c66089..71263806d 100644 --- a/idris-jvm-compiler/pom.xml +++ b/idris-jvm-compiler/pom.xml @@ -133,7 +133,7 @@ idris2-exec - -Xss70m -Xms3g -Xmx3g + -Xss92m -Xms3g -Xmx3g jvm @@ -180,7 +180,7 @@ jvm - -Xss70m -Xms3g -Xmx3g + -Xss92m -Xms3g -Xmx3g @@ -214,6 +214,7 @@ run + false diff --git a/idris-jvm-runtime/pom.xml b/idris-jvm-runtime/pom.xml index 22329398f..f089120ac 100644 --- a/idris-jvm-runtime/pom.xml +++ b/idris-jvm-runtime/pom.xml @@ -1,5 +1,6 @@ - + io.github.mmhelloworld idris-jvm diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Arrays.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Arrays.java index dd9f2f48c..30bb6e87a 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Arrays.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Arrays.java @@ -1,5 +1,6 @@ package io.github.mmhelloworld.idrisjvm.runtime; +import java.lang.reflect.Array; import java.util.ArrayList; import java.util.stream.Stream; @@ -14,4 +15,14 @@ public static ArrayList create(int size, T initialElement) { .limit(size) .collect(toCollection(() -> new ArrayList<>(size))); } + + public static int[] toIntArray(ArrayList arrayList) { + return arrayList.stream().mapToInt(i -> i).toArray(); + } + + public static T[] toArray(ArrayList arrayList, Class clazz) { + return arrayList.toArray((T[]) Array.newInstance(clazz, arrayList.size())); + } + + } diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIo.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIo.java index e63a6c3b6..bd5373928 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIo.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIo.java @@ -189,6 +189,65 @@ public static int getErrorNumber(ChannelIo file) { return file.getErrorNumber(); } + private static ChannelIo open(Path path, OpenOption... openOptions) throws IOException { + ensureParentDirectory(path); + return new ChannelIo(path, FileChannel.open(path, openOptions)); + } + + private static void ensureParentDirectory(Path path) throws IOException { + Path parent = path.getParent(); + if (parent != null) { + createDirectories(parent); + } + } + + private static boolean isReadOnlyMode(String mode) { + return "r".equalsIgnoreCase(mode); + } + + private static Collection getOpenOptions(String mode) { + switch (mode.toLowerCase()) { + case "r": + return singletonList(StandardOpenOption.READ); + case "w": + return asList(StandardOpenOption.CREATE, StandardOpenOption.WRITE, + StandardOpenOption.TRUNCATE_EXISTING); + case "a": + return asList(StandardOpenOption.CREATE, StandardOpenOption.APPEND); + case "r+": + return asList(StandardOpenOption.READ, StandardOpenOption.WRITE); + case "w+": + return asList(StandardOpenOption.CREATE, StandardOpenOption.READ, StandardOpenOption.WRITE); + case "a+": + return asList(StandardOpenOption.CREATE, StandardOpenOption.READ, StandardOpenOption.APPEND); + default: + throw new IllegalArgumentException("Unknown file mode " + mode); + } + } + + private static Set createPosixFilePermissions(int mode) { + return MODE_TO_PERMISSIONS.entrySet().stream() + .filter(modeAndPermission -> (mode & modeAndPermission.getKey()) == modeAndPermission.getKey()) + .map(Map.Entry::getValue) + .collect(toSet()); + } + + static int getErrorNumber(Exception currentException) { + if (currentException == null) { + return 0; + } else if (currentException instanceof FileNotFoundException + || currentException instanceof NoSuchFileException) { + return MISSING_FILE_ERROR_CODE; // To return error codes to conform to Idris functions with C FFIs + } else if (currentException instanceof AccessDeniedException + || currentException instanceof SecurityException) { + return SECURITY_ERROR_CODE; + } else if (currentException instanceof FileAlreadyExistsException) { + return EXISTING_FILE_ERROR_CODE; + } else { + return GENERAL_ERROR_CODE; + } + } + @Override public char readChar() { return (char) withExceptionHandling(() -> { @@ -352,49 +411,6 @@ public int write(ByteBuffer src) throws IOException { return ((WritableByteChannel) channel).write(src); } - private static ChannelIo open(Path path, OpenOption... openOptions) throws IOException { - ensureParentDirectory(path); - return new ChannelIo(path, FileChannel.open(path, openOptions)); - } - - private static void ensureParentDirectory(Path path) throws IOException { - Path parent = path.getParent(); - if (parent != null) { - createDirectories(parent); - } - } - - private static boolean isReadOnlyMode(String mode) { - return "r".equalsIgnoreCase(mode); - } - - private static Collection getOpenOptions(String mode) { - switch (mode.toLowerCase()) { - case "r": - return singletonList(StandardOpenOption.READ); - case "w": - return asList(StandardOpenOption.CREATE, StandardOpenOption.WRITE, - StandardOpenOption.TRUNCATE_EXISTING); - case "a": - return asList(StandardOpenOption.CREATE, StandardOpenOption.APPEND); - case "r+": - return asList(StandardOpenOption.READ, StandardOpenOption.WRITE); - case "w+": - return asList(StandardOpenOption.CREATE, StandardOpenOption.READ, StandardOpenOption.WRITE); - case "a+": - return asList(StandardOpenOption.CREATE, StandardOpenOption.READ, StandardOpenOption.APPEND); - default: - throw new IllegalArgumentException("Unknown file mode " + mode); - } - } - - private static Set createPosixFilePermissions(int mode) { - return MODE_TO_PERMISSIONS.entrySet().stream() - .filter(modeAndPermission -> (mode & modeAndPermission.getKey()) == modeAndPermission.getKey()) - .map(Map.Entry::getValue) - .collect(toSet()); - } - private T withExceptionHandling(SupplierE action) { exception = null; Runtime.setErrorNumber(0); @@ -442,20 +458,4 @@ private long withExceptionHandling(LongSupplierE action, lo return fallback; } } - - static int getErrorNumber(Exception currentException) { - if (currentException == null) { - return 0; - } else if (currentException instanceof FileNotFoundException - || currentException instanceof NoSuchFileException) { - return MISSING_FILE_ERROR_CODE; // To return error codes to conform to Idris functions with C FFIs - } else if (currentException instanceof AccessDeniedException - || currentException instanceof SecurityException) { - return SECURITY_ERROR_CODE; - } else if (currentException instanceof FileAlreadyExistsException) { - return EXISTING_FILE_ERROR_CODE; - } else { - return GENERAL_ERROR_CODE; - } - } } diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Concurrency.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Concurrency.java index 6c022554a..8f22ddd8c 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Concurrency.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Concurrency.java @@ -6,11 +6,11 @@ public final class Concurrency { private Concurrency() { } - public static void setThreadData(Object value) { - THREAD_LOCAL.set(value); - } - public static Object getThreadData() { return THREAD_LOCAL.get(); } + + public static void setThreadData(Object value) { + THREAD_LOCAL.set(value); + } } diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Conversion.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Conversion.java index 5fd5f3af2..939ccf839 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Conversion.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Conversion.java @@ -155,6 +155,19 @@ public static BigInteger toInteger(String value) { } } + public static BigInteger toInteger(Object value) { + if (value instanceof BigInteger) { + return (BigInteger) value; + } else if (value instanceof Integer) { + return BigInteger.valueOf((Integer) value); + } else if (value instanceof Long) { + return BigInteger.valueOf((Long) value); + } else { + throw new IllegalArgumentException(format("Unable to convert value %s of type %s to BigInteger", + value, value.getClass())); + } + } + public static int toInt(String value) { try { return new BigDecimal(value) diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisList.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisList.java index 41e00dbf0..3846fd3e8 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisList.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisList.java @@ -200,6 +200,29 @@ private Iterator(int index, IdrisList idrisList) { this.node = createNode(index, idrisList); } + private static Node createNode(int index, IdrisList idrisList) { + if (idrisList == Nil.INSTANCE) { + return null; + } + Cons cons = (Cons) idrisList; + Node currNode = new Node(cons.head); + int startIndex = -1; + Node start = new Node(null, EMPTY_ELEMENT, currNode); + for (IdrisList currList = (IdrisList) cons.tail; currList != Nil.INSTANCE; currList = + (IdrisList) ((Cons) currList).tail) { + Cons newCons = (Cons) currList; + Node newNode = new Node(newCons.head); + currNode.next = newNode; + newNode.previous = currNode; + currNode = currNode.next; + if (startIndex + 1 < index) { + start = newNode.previous; + startIndex++; + } + } + return startIndex + 1 != index ? null : start; + } + @Override public boolean hasNext() { return node != null && node.next != null; @@ -256,29 +279,6 @@ public void set(Object o) { public void add(Object o) { throw new UnsupportedOperationException("immutable list"); } - - private static Node createNode(int index, IdrisList idrisList) { - if (idrisList == Nil.INSTANCE) { - return null; - } - Cons cons = (Cons) idrisList; - Node currNode = new Node(cons.head); - int startIndex = -1; - Node start = new Node(null, EMPTY_ELEMENT, currNode); - for (IdrisList currList = (IdrisList) cons.tail; currList != Nil.INSTANCE; currList = - (IdrisList) ((Cons) currList).tail) { - Cons newCons = (Cons) currList; - Node newNode = new Node(newCons.head); - currNode.next = newNode; - newNode.previous = currNode; - currNode = currNode.next; - if (startIndex + 1 < index) { - start = newNode.previous; - startIndex++; - } - } - return startIndex + 1 != index ? null : start; - } } } } diff --git a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisSocket.java b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisSocket.java index aeca51c00..fe87a723d 100644 --- a/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisSocket.java +++ b/idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisSocket.java @@ -126,6 +126,36 @@ public static int getEagain() { return EAGAIN; } + private static void handleException(Exception e) { + Runtime.setException(e); + Runtime.setErrorNumber(getErrorNumber(e)); + } + + static int getErrorNumber(Exception exception) { + if (exception != null) { + exception.printStackTrace(); + } + // To return error codes to conform to Idris functions with C FFIs + if (exception == null) { + return 0; + } else if (exception instanceof FileNotFoundException || exception instanceof NoSuchFileException) { + return ErrorCodes.NO_SUCH_FILE; + } else if (exception instanceof InterruptedIOException || exception instanceof InterruptedException) { + Thread.currentThread().interrupt(); + return ErrorCodes.INTERRUPTED; + } else if (exception instanceof AccessDeniedException || exception instanceof SecurityException) { + return ErrorCodes.SOCKET_ACCESS_DENIED; + } else if (exception instanceof BindException) { + return ErrorCodes.CANNOT_ASSIGN_REQUESTED_ADDRESS; + } else if (exception instanceof ProtocolException) { + return ErrorCodes.PROTOCOL_ERROR; + } else if (exception instanceof NoRouteToHostException || exception instanceof UnknownHostException) { + return ErrorCodes.NO_ROUTE_TO_HOST; + } else { + return ErrorCodes.IO_ERROR; + } + } + public int bind(int socketFamily, int newSocketType, String hostName, int port) { return withExceptionHandling(() -> { InetSocketAddress socketAddress = new InetSocketAddress(hostName, port); @@ -292,11 +322,6 @@ public void close() { }); } - private static void handleException(Exception e) { - Runtime.setException(e); - Runtime.setErrorNumber(getErrorNumber(e)); - } - private void initialize(AbstractSelectableChannel newChannel) throws IOException { this.channel = newChannel; newChannel.configureBlocking(false); @@ -376,29 +401,4 @@ public SocketAddress getRemoteAddress() { return remoteAddress; } } - - static int getErrorNumber(Exception exception) { - if (exception != null) { - exception.printStackTrace(); - } - // To return error codes to conform to Idris functions with C FFIs - if (exception == null) { - return 0; - } else if (exception instanceof FileNotFoundException || exception instanceof NoSuchFileException) { - return ErrorCodes.NO_SUCH_FILE; - } else if (exception instanceof InterruptedIOException || exception instanceof InterruptedException) { - Thread.currentThread().interrupt(); - return ErrorCodes.INTERRUPTED; - } else if (exception instanceof AccessDeniedException || exception instanceof SecurityException) { - return ErrorCodes.SOCKET_ACCESS_DENIED; - } else if (exception instanceof BindException) { - return ErrorCodes.CANNOT_ASSIGN_REQUESTED_ADDRESS; - } else if (exception instanceof ProtocolException) { - return ErrorCodes.PROTOCOL_ERROR; - } else if (exception instanceof NoRouteToHostException || exception instanceof UnknownHostException) { - return ErrorCodes.NO_ROUTE_TO_HOST; - } else { - return ErrorCodes.IO_ERROR; - } - } } diff --git a/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIoTest.java b/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIoTest.java index 34e372290..3632e74f8 100644 --- a/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIoTest.java +++ b/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/ChannelIoTest.java @@ -22,6 +22,41 @@ @Disabled class ChannelIoTest { + static Stream readFile() throws IOException { + return Stream.of( + createArguments("file1.txt"), + createArguments("file2.txt")); + } + + private static Arguments createArguments(String fileName) throws IOException { + String path = getPath(fileName); + List content = readFile(path); + return arguments(path, content); + } + + private static List readFile(String path) throws IOException { + BufferedReader bufferedReader = Files.newBufferedReader(Paths.get(path)); + int currentChar; + List content = new ArrayList<>(); + StringBuilder line = new StringBuilder(); + while ((currentChar = bufferedReader.read()) != -1) { + line.append((char) currentChar); + if (currentChar == '\n') { + content.add(line.toString()); + line = new StringBuilder(); + } + } + String lineStr = line.toString(); + if (!lineStr.isEmpty()) { + content.add(lineStr); + } + return content; + } + + private static String getPath(String name) { + return new File(requireNonNull(currentThread().getContextClassLoader().getResource(name)).getFile()).getPath(); + } + @ParameterizedTest @MethodSource("readFile") void readFile1(String fileName, List expectedContent) { @@ -64,39 +99,4 @@ private List testReadFile2(String fileName) { } return content; } - - static Stream readFile() throws IOException { - return Stream.of( - createArguments("file1.txt"), - createArguments("file2.txt")); - } - - private static Arguments createArguments(String fileName) throws IOException { - String path = getPath(fileName); - List content = readFile(path); - return arguments(path, content); - } - - private static List readFile(String path) throws IOException { - BufferedReader bufferedReader = Files.newBufferedReader(Paths.get(path)); - int currentChar; - List content = new ArrayList<>(); - StringBuilder line = new StringBuilder(); - while ((currentChar = bufferedReader.read()) != -1) { - line.append((char) currentChar); - if (currentChar == '\n') { - content.add(line.toString()); - line = new StringBuilder(); - } - } - String lineStr = line.toString(); - if (!lineStr.isEmpty()) { - content.add(lineStr); - } - return content; - } - - private static String getPath(String name) { - return new File(requireNonNull(currentThread().getContextClassLoader().getResource(name)).getFile()).getPath(); - } -} \ No newline at end of file +} diff --git a/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisListTest.java b/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisListTest.java index bb679535a..edd63f59b 100644 --- a/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisListTest.java +++ b/idris-jvm-runtime/src/test/java/io/github/mmhelloworld/idrisjvm/runtime/IdrisListTest.java @@ -12,13 +12,15 @@ class IdrisListTest { @Test void reverse() { assertThat(IdrisList.reverse(IdrisList.Nil.INSTANCE)).isEqualTo(IdrisList.Nil.INSTANCE); - assertThat(IdrisList.reverse(new IdrisList.Cons(1, new IdrisList.Cons(2, new IdrisList.Cons(3, IdrisList.Nil.INSTANCE))))) - .isEqualTo(new IdrisList.Cons(3, new IdrisList.Cons(2, new IdrisList.Cons(1, IdrisList.Nil.INSTANCE)))); + assertThat(IdrisList.reverse(new IdrisList.Cons(1, new IdrisList.Cons(2, + new IdrisList.Cons(3, IdrisList.Nil.INSTANCE))))) + .isEqualTo(new IdrisList.Cons(3, new IdrisList.Cons(2, + new IdrisList.Cons(1, IdrisList.Nil.INSTANCE)))); } @Test void fromArray_char() { - assertThat(IdrisList.fromArray(new String[] {})).isEmpty(); + assertThat(IdrisList.fromArray(new String[]{})).isEmpty(); assertThat(IdrisList.fromArray("helloworld".toCharArray())) .containsExactlyElementsOf(asList("helloworld".toCharArray())); } @@ -30,4 +32,4 @@ void fromIterable() { assertThat(IdrisList.fromIterable(asList("helloworld".toCharArray()))) .containsExactlyElementsOf(asList("helloworld".toCharArray())); } -} \ No newline at end of file +} diff --git a/idris-jvm-tests/pom.xml b/idris-jvm-tests/pom.xml index f1701608e..e7ad2e6c4 100644 --- a/idris-jvm-tests/pom.xml +++ b/idris-jvm-tests/pom.xml @@ -20,6 +20,7 @@ + ${project.parent.basedir}/tests/build/exec/runtests_app org.codehaus.mojo @@ -89,10 +90,9 @@ default-jar - none + package - unwanted - unwanted + ${project.parent.basedir}/tests/build/exec/runtests_app @@ -110,7 +110,7 @@ maven-dependency-plugin - compile + package copy-dependencies @@ -120,23 +120,6 @@ - - maven-antrun-plugin - - - copy-runtests-jar - compile - - run - - - - - - - - - org.apache.maven.plugins maven-gpg-plugin diff --git a/idris2.ipkg b/idris2.ipkg index a6f86b44b..243cfc7aa 100644 --- a/idris2.ipkg +++ b/idris2.ipkg @@ -1,6 +1,6 @@ package idris2app -depends = network +depends = network, contrib sourcedir = "src" diff --git a/idris2api.ipkg b/idris2api.ipkg index b0e036de7..5f86670ec 100644 --- a/idris2api.ipkg +++ b/idris2api.ipkg @@ -48,6 +48,7 @@ modules = Compiler.Jvm.Math, Compiler.Jvm.Asm, Compiler.Jvm.Codegen, + Compiler.Jvm.Export, Compiler.Jvm.ExtPrim, Compiler.Jvm.FunctionTree, Compiler.Jvm.Optimizer, diff --git a/libs/base/Java/Lang.idr b/libs/base/Java/Lang.idr index e9d329aa8..0c000b334 100644 --- a/libs/base/Java/Lang.idr +++ b/libs/base/Java/Lang.idr @@ -1,5 +1,7 @@ module Java.Lang +import System.FFI + public export interface Inherits child parent where constructor MkInherits @@ -12,15 +14,192 @@ public export Inherits a a where namespace Object - export - data Object : Type where [external] + public export + Object : Type + Object = Struct "java/lang/Object" [] %foreign "jvm:.toString(java/lang/Object java/lang/String),java/lang/Object" prim_toString : Object -> PrimIO String + %foreign "jvm:,java/lang/Object" + prim_new : PrimIO Object + + export %inline + new : HasIO io => io Object + new = primIO prim_new + export %inline toString : (HasIO io, Inherits a Object) => a -> io String toString obj = primIO $ prim_toString (subtyping obj) public export Inherits a Object where + +namespace Class + public export + Class : Type -> Type + Class ty = Struct "java/lang/Class" [("<>", ty)] + +%extern prim__jvmClassLiteral : (ty: Type) -> Class ty + +public export +%extern prim__jvmInstanceOf : a -> (ty: Type) -> Bool + +%extern prim__jvmRefEq : a -> b -> Bool + +public export %inline +classLiteral : {ty: Type} -> Class ty +classLiteral {ty} = prim__jvmClassLiteral ty + +public export %inline +jvmInstanceOf : a -> (ty: Type) -> Bool +jvmInstanceOf = prim__jvmInstanceOf + +public export +jvmRefEq : a -> b -> Bool +jvmRefEq = prim__jvmRefEq + +export +%extern prim__javaLambda : (lambdaTy : Type) -> (intfTy : Type) -> (f: lambdaTy) -> intfTy + +public export +%inline +jlambda : {fTy: Type} -> (f: fTy) -> {intfTy: Type} -> intfTy +jlambda {fTy} f {intfTy} = prim__javaLambda fTy intfTy f + +public export +data FArgList : Type where + Nil : FArgList + (::) : {a : Type} -> (1 arg : a) -> (1 args : FArgList) -> FArgList + +export +%extern prim__jvmSuper : Type -> (1 args : FArgList) -> PrimIO () + +export %inline +super : Type -> (1 args : FArgList) -> IO () +super clazz args = fromPrim (prim__jvmSuper clazz args) + +namespace JInteger + public export + JInteger : Type + JInteger = Struct "java/lang/Integer" [] + + export + %foreign "jvm:valueOf,java/lang/Integer" + box : Int -> JInteger + + export + %foreign "jvm:.intValue" + unbox : JInteger -> Int + +public export +data Array : (elemTy: Type) -> Type where + +export +%extern prim__jvmNewArray : (ty: Type) -> Int -> PrimIO (Array ty) + +export +%extern prim__jvmSetArray : (a: Type) -> Int -> a -> Array a -> PrimIO () + +export +%extern prim__jvmGetArray : (a: Type) -> Int -> Array a -> PrimIO a + +export +%extern prim__jvmArrayLength : (a: Type) -> Array a -> Int + +isPrimitive : Type -> Bool +isPrimitive Bool = True +isPrimitive Char = True +isPrimitive Int8 = True +isPrimitive Int16 = True +isPrimitive Int32 = True +isPrimitive Int = True +isPrimitive Int64 = True +isPrimitive Bits8 = True +isPrimitive Bits16 = True +isPrimitive Bits32 = True +isPrimitive Bits64 = True +isPrimitive Double = True +isPrimitive _ = False + +public export +%foreign "jvm:nullValue(java/lang/Object),io/github/mmhelloworld/idrisjvm/runtime/Runtime" +nullValue : a + +public export +%foreign jvm' "java/util/Objects" "isNull" "java/lang/Object" "boolean" +isNull : Object -> Bool + +namespace Long + + public export + Long : Type + Long = Struct "java/lang/Long" [] + + %foreign "jvm:valueOf,java/lang/Long" + export + valueOf : Int64 -> Long + +namespace Array + %inline + public export + new : HasIO io => {elem: Type} -> Int -> io (Array elem) + new {elem} size = primIO $ prim__jvmNewArray elem size + + %inline + public export + set : HasIO io => {elem: Type} -> Array elem -> Int -> elem -> io Bool + set {elem} array index value = do + let len = prim__jvmArrayLength elem array + if index >= 0 && index < len + then do + primIO $ prim__jvmSetArray elem index value array + pure True + else pure False + + %inline + public export + get : HasIO io => {elem: Type} -> Array elem -> Int -> io (Maybe elem) + get {elem} array index = do + let len = prim__jvmArrayLength elem array + if index >= 0 && index < len + then do + value <- primIO $ prim__jvmGetArray elem index array + if isPrimitive elem + then pure (Just value) + else + if isNull (believe_me value) + then pure Nothing + else pure (Just value) + else pure Nothing + +public export +Runnable : Type +Runnable = (Struct "java/lang/Runnable run" [], PrimIO ()) + +namespace Thread + + public export %inline + Thread : Type + Thread = Struct "java/lang/Thread" [] + + %foreign "jvm:" + prim_new : Runnable -> PrimIO Thread + + %foreign "jvm:.start" + prim_start : Thread -> PrimIO () + + %foreign "jvm:.join" + prim_join : Thread -> PrimIO () + + export + new : HasIO io => PrimIO () -> io Thread + new runnable = primIO $ prim_new (jlambda runnable) + + export + start : HasIO io => Thread -> io () + start = primIO . prim_start + + export + join : HasIO io => Thread -> io () + join = primIO . prim_join diff --git a/libs/base/Java/Util.idr b/libs/base/Java/Util.idr index a090cddc1..55057ea5d 100644 --- a/libs/base/Java/Util.idr +++ b/libs/base/Java/Util.idr @@ -1,10 +1,128 @@ module Java.Util +import Java.Util.Function import Java.Lang +import System.FFI + +%hide Prelude.Stream.Stream + +namespace Arrays + public export + Arrays : Type + Arrays = Struct "java/util/Arrays" [] + + export + %foreign "jvm:toString,java/util/Arrays" + prim_boolArrayToString : Array Bool -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_charArrayToString : Array Char -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_byteArrayToString : Array Int8 -> PrimIO String -namespace Collection export - data Collection : Type -> Type where [external] + %foreign "jvm:toString,java/util/Arrays" + prim_shortArrayToString : Array Int16 -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_int32ArrayToString : Array Int32 -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_intArrayToString : Array Int -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_int64ArrayToString : Array Int64 -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_doubleArrayToString : Array Double -> PrimIO String + + export + %foreign "jvm:toString,java/util/Arrays" + prim_arrayToString : Array Object -> PrimIO String + + namespace BoolArray + public export %inline + toString : (HasIO io) => Array Bool -> io String + toString arr = primIO $ prim_boolArrayToString arr + + namespace CharArray + public export %inline + toString : (HasIO io) => Array Char -> io String + toString arr = primIO $ prim_charArrayToString arr + + namespace ByteArray + public export %inline + toString : (HasIO io) => Array Int8 -> io String + toString arr = primIO $ prim_byteArrayToString arr + + namespace ShortArray + public export %inline + toString : (HasIO io) => Array Int16 -> io String + toString arr = primIO $ prim_shortArrayToString arr + + namespace Int32Array + public export %inline + toString : (HasIO io) => Array Int32 -> io String + toString arr = primIO $ prim_int32ArrayToString arr + + namespace IntArray + public export %inline + toString : (HasIO io) => Array Int -> io String + toString arr = primIO $ prim_intArrayToString arr + + namespace Int64Array + public export %inline + toString : (HasIO io) => Array Int64 -> io String + toString arr = primIO $ prim_int64ArrayToString arr + + namespace DoubleArray + public export %inline + toString : (HasIO io) => Array Double -> io String + toString arr = primIO $ prim_doubleArrayToString arr + + namespace ObjectArray + public export %inline + toString : (HasIO io) => Array Object -> io String + toString arr = primIO $ prim_arrayToString arr + + public export %inline + fromList : HasIO io => (a: Type) -> List a -> io (Array a) + fromList a xs = do + let len = length xs + arr <- primIO $ prim__jvmNewArray a (cast len) + let setter = \index: Int, value: a => prim__jvmSetArray a index value arr + go setter 0 xs + pure arr + where + go : (Int -> a -> PrimIO ()) -> Int -> List a -> io () + go _ _ [] = pure () + go setter index (x :: xs) = do + primIO $ setter index x + go setter (index + 1) xs + +namespace Objects + %foreign "jvm:hash,java/util/Objects" + prim_hash : Array Object -> PrimIO Int + + export %inline + hash : (HasIO io) => Array Object -> io Int + hash array = primIO $ prim_hash array + +public export %inline +Comparator : Type -> Type +Comparator a = (Struct "java/util/Comparator compare" [], Object -> Object -> Int) + +namespace Collection + public export + Collection : Type -> Type + Collection elem = Struct "i:java/util/Collection" [("<>", elem)] %foreign "jvm:.add(i:java/util/Collection java/lang/Object Bool),java/util/Collection" prim_add : Collection a -> a -> PrimIO Bool @@ -22,8 +140,9 @@ namespace Collection namespace JList - export - data JList : Type -> Type where [external] + public export + JList : Type -> Type + JList elem = Struct "i:java/util/List" [("<>", elem)] %foreign "jvm:.get(i:java/util/List int java/lang/Object),java/util/List" prim_get : JList a -> Int -> PrimIO a @@ -39,8 +158,9 @@ public export Inherits obj (JList a) => Inherits obj (Collection a) where namespace ArrayList - export - data ArrayList : Type -> Type where [external] + public export + ArrayList : Type -> Type + ArrayList elem = Struct "java/util/ArrayList" [("<>", elem)] %foreign "jvm:(java/util/ArrayList),java/util/ArrayList" prim_new : PrimIO (ArrayList a) @@ -53,8 +173,9 @@ public export Inherits (ArrayList a) (JList a) where namespace Map - export - data Map : (key: Type) -> (value: Type) -> Type where [external] + public export + Map : (key: Type) -> (value: Type) -> Type + Map key value = Struct "i:java/util/Map" [("<>", key), ("<>", value)] %foreign "jvm:.put(i:java/util/Map java/lang/Object java/lang/Object java/lang/Object),java/util/Map" prim_put : Map key value -> key -> value -> PrimIO value @@ -71,8 +192,9 @@ namespace Map get map key = primIO (prim_get (subtyping map) key) namespace HashMap - export - data HashMap : (key: Type) -> (value: Type) -> Type where [external] + public export + HashMap : (key: Type) -> (value: Type) -> Type + HashMap key value = Struct "java/util/HashMap" [("<>", key), ("<>", value)] %foreign "jvm:(java/util/HashMap),java/util/HashMap" prim_new : PrimIO (HashMap key value) @@ -83,3 +205,37 @@ namespace HashMap public export Inherits (HashMap key value) (Map key value) where + +namespace Stream + + public export + Stream : Type -> Type + Stream a = Struct "i:java/util/stream/Stream" [("<>", a)] + + %foreign "jvm:.stream(i:java/util/Collection java/util/stream/Stream)" + prim_fromCollection : Collection a -> PrimIO (Stream a) + + export + fromCollection : (HasIO io, Inherits obj (Collection a)) => obj -> io (Stream a) + fromCollection collection = primIO $ prim_fromCollection {a} (subtyping collection) + + %foreign "jvm:.map" + prim_map : Stream a -> Function a b -> PrimIO (Stream b) + + %foreign "jvm:.filter" + prim_filter : Stream a -> Predicate a -> PrimIO (Stream a) + + export + map : HasIO io => {a, b: Type} -> Stream a -> (a -> PrimIO b) -> io (Stream b) + map {a} {b} stream f = primIO $ prim_map {a} {b} stream (jlambda f) + + export + filter : HasIO io => {a: Type} -> Stream a -> (a -> PrimIO Bool) -> io (Stream a) + filter {a} stream f = primIO $ prim_filter {a} stream (jlambda f) + + %foreign "jvm:.count" + prim_count : Stream a -> PrimIO Int64 + + export + count : HasIO io => Stream a -> io Int64 + count = primIO . prim_count {a} diff --git a/libs/base/Java/Util/Function.idr b/libs/base/Java/Util/Function.idr new file mode 100644 index 000000000..3933ad4dd --- /dev/null +++ b/libs/base/Java/Util/Function.idr @@ -0,0 +1,56 @@ +module Java.Util.Function + +import Java.Lang +import System.FFI + +namespace Function + + public export %inline + Function : Type -> Type -> Type + Function a b = (Struct "java/util/function/Function apply" [("<>", a), ("<>", b)], Object -> PrimIO Object) + + %foreign "jvm:.apply" + prim_apply : Function a b -> a -> PrimIO b + + public export %inline + apply : HasIO io => Function a b -> a -> io b + apply f a = primIO $ prim_apply f a + +namespace BiFunction + + public export %inline + BiFunction : Type -> Type -> Type -> Type + BiFunction a b c = (Struct "java/util/function/BiFunction apply" [("<>", a), ("<>", b), ("<>", c)], Object -> Object -> PrimIO Object) + + %foreign "jvm:.apply" + prim_apply : BiFunction a b c -> a -> b -> PrimIO c + + public export %inline + apply : HasIO io => {a, b, c: Type} -> (a -> b -> PrimIO c) -> (x: a) -> (y: b) -> io c + apply {a} {b} {c} f x y = primIO $ prim_apply (jlambda f) x y + +namespace Predicate + + public export %inline + Predicate : Type -> Type + Predicate a = (Struct "java/util/function/Predicate test" [("<>", a)], Object -> PrimIO Bool) + + %foreign "jvm:.test" + prim_test : Predicate a -> a -> PrimIO Bool + + public export + test : HasIO io => Predicate a -> a -> io Bool + test f a = primIO $ prim_test f a + +namespace Supplier + + public export %inline + Supplier : Type -> Type + Supplier a = (Struct "java/util/function/Supplier get" [("<>", a)], PrimIO Object) + + %foreign "jvm:.get" + prim_get : Supplier a -> PrimIO a + + public export %inline + get : HasIO io => Supplier a -> io a + get = primIO . prim_get diff --git a/src/Compiler/Jvm/Asm.idr b/src/Compiler/Jvm/Asm.idr index 264929319..404d70710 100644 --- a/src/Compiler/Jvm/Asm.idr +++ b/src/Compiler/Jvm/Asm.idr @@ -6,14 +6,17 @@ import Compiler.Inline import Core.Context import Core.Name +import Core.Reflect import Core.TT import Data.List +import Data.List1 import Data.Maybe import Data.String import Libraries.Data.SortedSet import Libraries.Data.String.Extra import Data.Vect +import Debug.Trace import Compiler.Jvm.Tuples import Compiler.Jvm.InferredType @@ -23,6 +26,8 @@ import Compiler.Jvm.ShowUtil import System import System.FFI +%hide Debug.Trace.toString + public export data Assembler : Type where [external] @@ -51,15 +56,19 @@ data JInteger : Type where [external] data JDouble : Type where [external] data JLong : Type where [external] -namespace Collection - export - data CollectionNative : Type where [external] +public export +interface Inherits child parent where + constructor MkInherits - export - Collection : Type -> Type - Collection a = CollectionNative + export %inline + subtyping : child -> parent + subtyping = believe_me + +public export +Inherits a a where namespace Object + export data Object : Type where [external] @@ -77,9 +86,12 @@ namespace Object hashCode : a -> Int hashCode obj = unsafePerformIO $ primIO $ prim_hashCode (believe_me obj) +public export +Inherits a Object where + public export %foreign "jvm:nullValue(java/lang/Object),io/github/mmhelloworld/idrisjvm/runtime/Runtime" -nullValue : Object +nullValue : a public export %foreign jvm' "java/util/Objects" "isNull" "java/lang/Object" "boolean" @@ -88,111 +100,128 @@ isNull : Object -> Bool public export maybeToNullable : Maybe t -> t maybeToNullable (Just t) = t -maybeToNullable Nothing = believe_me nullValue +maybeToNullable Nothing = nullValue public export -nullableToMaybe : Object -> Maybe Object -nullableToMaybe value = if isNull value then Nothing else Just value +nullableToMaybe : a -> Maybe a +nullableToMaybe value = if isNull (believe_me value) then Nothing else Just value namespace Iterable export - data JIterable : Type where [external] + data Iterable : Type -> Type where [external] +namespace Collection export - Iterable : Type -> Type - Iterable a = JIterable + data Collection : Type -> Type where [external] + + %foreign "jvm:.add(i:java/util/Collection java/lang/Object Bool),java/util/Collection" + prim_add : Collection a -> a -> PrimIO Bool + + %foreign "jvm:.size(i:java/util/Collection int),java/util/Collection" + prim_size : Collection a -> PrimIO Int + + export %inline + add : HasIO io => obj -> elemTy -> (Inherits obj (Collection elemTy)) => io Bool + add collection elem = primIO $ prim_add (subtyping collection) elem + + export %inline + size : (HasIO io, Inherits obj (Collection elemTy)) => obj -> io Int + size {elemTy} collection = primIO $ prim_size {a=elemTy} (subtyping collection) + +public export +Inherits (Collection a) (Iterable a) where namespace JList - export - data JListNative : Type where [external] export - JList : Type -> Type - JList a = JListNative - - %foreign "jvm:(java/lang/Object java/util/ArrayList),java/util/ArrayList" - prim_newArrayList : PrimIO JListNative + data JList : Type -> Type where [external] %foreign jvm' "java/util/List" ".add" "i:java/util/List int java/lang/Object" "void" - prim_add : JListNative -> Int -> Object -> PrimIO () + prim_add : JList a -> Int -> a -> PrimIO () %foreign jvm' "java/util/List" ".addAll" "i:java/util/List java/util/Collection" "boolean" - prim_addAll : JListNative -> CollectionNative -> PrimIO Bool + prim_addAll : JList a -> Collection a -> PrimIO Bool %foreign jvm' "java/util/List" ".set" "i:java/util/List int java/lang/Object" "java/lang/Object" - prim_set : JListNative -> Int -> Object -> PrimIO Object - - %foreign jvm' "java/util/List" ".get" "i:java/util/List int" "java/lang/Object" - prim_get : JListNative -> Int -> PrimIO Object - - %foreign jvm' "java/util/List" ".size" "i:java/util/List" "int" - prim_size : JListNative -> PrimIO Int - - export - new : HasIO io => io (JList a) - new = believe_me <$> primIO prim_newArrayList + prim_set : JList a -> Int -> a -> PrimIO a export add : HasIO io => JList a -> Int -> a -> io () - add list index value = primIO $ prim_add (believe_me list) index (believe_me value) + add list index value = primIO $ prim_add list index value export - addAll : HasIO io => JList a -> Collection a -> io Bool - addAll list collection = primIO $ prim_addAll (believe_me list) (believe_me collection) + addAll : (HasIO io, Inherits obj (Collection a)) => JList a -> obj -> io Bool + addAll list collection = primIO $ prim_addAll list (subtyping collection) - export - set : HasIO io => JList a -> Int -> a -> io a - set list index value = believe_me <$> (primIO $ prim_set (believe_me list) index (believe_me value)) + %foreign "jvm:.get(i:java/util/List int java/lang/Object),java/util/List" + prim_get : JList a -> Int -> PrimIO a - export - get : HasIO io => JList a -> Int -> io a - get list index = believe_me <$> (primIO $ prim_get (believe_me list) index) + export %inline + get : (HasIO io, Inherits list (JList elemTy)) => list -> Int -> io elemTy + get list index = primIO $ prim_get (subtyping list) index export - size : HasIO io => JList a -> io Int - size list = believe_me <$> (primIO $ prim_size (believe_me list)) + set : HasIO io => JList a -> Int -> a -> io a + set list index value = primIO $ prim_set list index value %foreign jvm' "java/util/Collections" "nCopies" "int java/lang/Object" "java/util/List" - prim_nCopies : Int -> Object -> PrimIO JListNative + prim_nCopies : Int -> a -> PrimIO (JList a) export nCopies : HasIO io => Int -> a -> io (JList a) - nCopies n value = believe_me <$> (primIO $ prim_nCopies n (believe_me value)) + nCopies n value =primIO $ prim_nCopies n value %foreign jvm' "io/github/mmhelloworld/idrisjvm/runtime/IdrisList" "fromIterable" "java/lang/Iterable" "io/github/mmhelloworld/idrisjvm/runtime/IdrisList" - prim_fromIterable : JIterable -> PrimIO JListNative + prim_fromIterable : Iterable a -> PrimIO (List a) export - fromIterable : HasIO io => Iterable a -> io (List a) - fromIterable iterable = believe_me <$> (primIO $ prim_fromIterable (believe_me iterable)) + fromIterable : (HasIO io, Inherits obj (Iterable a)) => obj -> io (List a) + fromIterable iterable = primIO $ prim_fromIterable (subtyping iterable) -namespace Entry - data JEntry : Type where [external] +public export +Inherits (JList a) (Iterable a) where +public export +Inherits (List a) (JList a) where + +namespace ArrayList + export + data ArrayList : Type -> Type where [external] + + %foreign "jvm:(java/util/ArrayList),java/util/ArrayList" + prim_new : PrimIO (ArrayList a) + + export %inline + new : HasIO io => io (ArrayList elemTy) + new = primIO prim_new + +public export +Inherits (ArrayList a) (JList a) where + +namespace Entry export - Entry : Type -> Type -> Type - Entry k v = JEntry + data Entry : Type -> Type -> Type where [external] %foreign "jvm:(java/lang/Object java/lang/Object java/util/AbstractMap$SimpleImmutableEntry),java/util/AbstractMap$SimpleImmutableEntry" - prim_new : Object -> Object -> PrimIO JEntry + prim_new : key -> value -> PrimIO (Entry key value) export new : HasIO io => k -> v -> io (Entry k v) - new key value = believe_me <$> primIO (prim_new (believe_me key) (believe_me value)) + new key value = primIO (prim_new key value) %foreign jvm' "java/util/Map$Entry" ".getKey" "i:java/util/Map$Entry" "java/lang/Object" - prim_getKey : JEntry -> PrimIO Object + prim_getKey : Entry key value -> PrimIO key export getKey : HasIO io => Entry k v -> io k - getKey entry = believe_me <$> primIO (prim_getKey (believe_me entry)) + getKey entry = primIO (prim_getKey entry) %foreign jvm' "java/util/Map$Entry" ".getValue" "i:java/util/Map$Entry" "java/lang/Object" - prim_getValue : JEntry -> PrimIO Object + prim_getValue : Entry key value -> PrimIO value export getValue : HasIO io => Entry k v -> io v - getValue entry = believe_me <$> primIO (prim_getValue (believe_me entry)) + getValue entry = primIO (prim_getValue entry) export toTuple : HasIO io => Entry k v -> io (k, v) @@ -202,34 +231,30 @@ namespace Entry pure (key, value) namespace Map - export - data JMap : Type where [external] export - Map : Type -> Type -> Type - Map k v = JMap + data Map : (key: Type) -> (value: Type) -> Type where [external] - %foreign "jvm:(java/lang/Object java/util/TreeMap),java/util/TreeMap" - prim_newTreeMap : PrimIO JMap + %foreign "jvm:.put(i:java/util/Map java/lang/Object java/lang/Object java/lang/Object),java/util/Map" + prim_put : Map key value -> key -> value -> PrimIO value - export - newTreeMap : HasIO io => io (Map key value) - newTreeMap = believe_me <$> primIO prim_newTreeMap + %foreign "jvm:.get(i:java/util/Map java/lang/Object java/lang/Object),java/util/Map" + prim_get : Map key value -> key -> PrimIO value - %foreign jvm' "java/util/Map" ".get" "i:java/util/Map java/lang/Object" "java/lang/Object" - prim_get : JMap -> Object -> PrimIO Object + export %inline + put : (HasIO io, Inherits obj (Map key value)) => obj -> key -> value -> io value + put map key value = primIO $ prim_put (subtyping map) key value - export - get : HasIO io => Map key value -> key -> io (Maybe value) - get map key = (believe_me . nullableToMaybe) <$> (primIO $ prim_get (believe_me map) (believe_me key)) + export %inline + get : (HasIO io, Inherits obj (Map key value)) => obj -> key -> io value + get map key = primIO (prim_get (subtyping map) key) - %foreign jvm' "java/util/Map" ".put" "i:java/util/Map java/lang/Object java/lang/Object" "java/lang/Object" - prim_put : JMap -> Object -> Object -> PrimIO Object + %foreign "jvm:(java/lang/Object java/util/TreeMap),java/util/TreeMap" + prim_newTreeMap : PrimIO (Map key value) export - put : HasIO io => Map key value -> key -> value -> io (Maybe value) - put this key value = (believe_me . nullableToMaybe) <$> (primIO $ prim_put (believe_me this) (believe_me key) - (believe_me value)) + newTreeMap : HasIO io => io (Map key value) + newTreeMap = primIO prim_newTreeMap goFromList : HasIO io => Map key value -> List (key, value) -> io () goFromList _ [] = pure () @@ -245,27 +270,27 @@ namespace Map pure m %foreign jvm' "java/util/Map" ".containsKey" "i:java/util/Map java/lang/Object" "boolean" - prim_containsKey : JMap -> Object -> PrimIO Bool + prim_containsKey : Map key value -> key -> PrimIO Bool export containsKey : HasIO io => Map key value -> key -> io Bool - containsKey this key = primIO $ prim_containsKey (believe_me this) (believe_me key) + containsKey this key = primIO $ prim_containsKey this key %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Maps" "transpose" "java/util/Map" "java/util/Map" - prim_transpose : JMap -> PrimIO JMap + prim_transpose : Map key value -> PrimIO (Map value key) export transpose : HasIO io => Map k v -> io (Map v k) - transpose m = believe_me <$> primIO (prim_transpose $ believe_me m) + transpose m = primIO (prim_transpose m) %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Maps" "toList" "java/util/Map" "java/util/List" - prim_toEntries : JMap -> PrimIO JListNative + prim_toEntries : Map key value -> PrimIO (JList (Entry key value)) export toEntries : HasIO io => Map key value -> io (List (Entry key value)) toEntries m = do - entries <- primIO (prim_toEntries $ believe_me m) - JList.fromIterable (believe_me entries) + entries <- primIO (prim_toEntries m) + JList.fromIterable entries export toList : HasIO io => Map k v -> io (List (k, v)) @@ -274,37 +299,35 @@ namespace Map traverse toTuple entries %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Maps" "keys" "java/util/Map" "java/util/List" - prim_keys : JMap -> PrimIO JListNative + prim_keys : Map key value -> PrimIO (JList key) export keys : HasIO io => Map key value -> io (List key) keys m = do - jkeys <- primIO (prim_keys $ believe_me m) - JList.fromIterable (believe_me jkeys) + jkeys <- primIO (prim_keys m) + JList.fromIterable jkeys %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Maps" "values" "java/util/Map" "java/util/List" - prim_values : JMap -> PrimIO JListNative + prim_values : Map key value -> PrimIO (JList value) export values : HasIO io => Map key value -> io (List value) values m = do - jvalues <- primIO (prim_values $ believe_me m) - JList.fromIterable (believe_me jvalues) + jvalues <- primIO (prim_values m) + JList.fromIterable jvalues %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Maps" "getValue2" "java/util/Map" "java/util/Map" - prim_getValue2 : JMap -> PrimIO JMap + prim_getValue2 : Map key (Entry value1 value2) -> PrimIO (Map key value2) export getValue2 : HasIO io => Map k (Entry v1 v2) -> io (Map k v2) - getValue2 m = believe_me <$> primIO (prim_getValue2 (believe_me m)) + getValue2 m = primIO (prim_getValue2 m) namespace EnumInt export succ : Int -> Int succ n = n + 1 -data Collection : Type where [external] - %inline public export runtimeClass : String @@ -325,12 +348,6 @@ record Scope where labels : (String, String) childIndices : List Int -public export -record InferredFunctionType where - constructor MkInferredFunctionType - returnType : InferredType - parameterTypes : List InferredType - public export record Function where constructor MkFunction @@ -347,12 +364,13 @@ namespace AsmGlobalState public export %foreign - "jvm:(String io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState),io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" - prim_newAsmGlobalState : String -> PrimIO AsmGlobalState + "jvm:(String java/util/Map io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState),io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" + prim_newAsmGlobalState : String -> Map String (FC, NamedDef) -> PrimIO AsmGlobalState public export - newAsmGlobalState : HasIO io => String -> io AsmGlobalState - newAsmGlobalState programName = primIO $ prim_newAsmGlobalState programName + newAsmGlobalState : HasIO io => String -> Map String (FC, NamedDef) -> io AsmGlobalState + newAsmGlobalState programName fcAndDefinitionsByName = + primIO $ prim_newAsmGlobalState programName fcAndDefinitionsByName public export %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" ".getAssembler" @@ -369,10 +387,19 @@ namespace AsmGlobalState "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" "String" prim_getProgramName : AsmGlobalState -> PrimIO String + public export + %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" ".getFcAndDefinition" + "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState String" "java/lang/Object" + prim_getFcAndDefinition : AsmGlobalState -> String -> PrimIO (FC, NamedDef) + public export getProgramName : HasIO io => AsmGlobalState -> io String getProgramName = primIO . prim_getProgramName + public export + getFcAndDefinition : HasIO io => AsmGlobalState -> String -> io (FC, NamedDef) + getFcAndDefinition state name = primIO $ prim_getFcAndDefinition state name + public export %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState" ".addConstructor" "io/github/mmhelloworld/idrisjvm/assembler/AsmGlobalState String" "void" @@ -466,15 +493,32 @@ record AsmState where assembler : Assembler public export -data Access = Private | Public | Static | Synthetic | Final +data Access = Private | Public | Protected | Static | Synthetic | Final | Interface | Abstract | Transient + +export +Eq Access where + Private == Private = True + Public == Public = True + Protected == Protected = True + Static == Static = True + Synthetic == Synthetic = True + Final == Final = True + Interface == Interface = True + Abstract == Abstract = True + Transient == Transient = True + _ == _ = False export Show Access where show Private = "Private" show Public = "Public" + show Protected = "Protected" show Static = "Static" show Synthetic = "Synthetic" show Final = "Final" + show Interface = "Interface" + show Abstract = "Abstract" + show Transient = "Transient" public export data FieldInstructionType = GetStatic | PutStatic | GetField | PutField @@ -498,7 +542,7 @@ Show InvocationType where show InvokeStatic = "InvokeStatic" show InvokeVirtual = "InvokeVirtual" -export +public export data ClassOpts = ComputeMaxs | ComputeFrames export @@ -531,6 +575,7 @@ data BsmArg = BsmArgGetType String | BsmArgHandle Handle data FieldInitialValue = IntField Int | StringField String | DoubleField Double mutual + public export data AnnotationValue = AnnInt Int | AnnBoolean Bool | AnnChar Char @@ -541,11 +586,23 @@ mutual | AnnArray (List AnnotationValue) | AnnAnnotation Annotation + public export AnnotationProperty : Type AnnotationProperty = (String, Asm.AnnotationValue) + public export data Annotation = MkAnnotation String (List AnnotationProperty) +export +getStringAnnotationValue : AnnotationValue -> Maybe String +getStringAnnotationValue (AnnString value) = Just value +getStringAnnotationValue _ = Nothing + +export +getStringAnnotationValues : AnnotationValue -> List String +getStringAnnotationValues (AnnArray values) = mapMaybe getStringAnnotationValue values +getStringAnnotationValues _ = [] + public export data Asm : Type -> Type where Aaload : Asm () @@ -571,11 +628,11 @@ data Asm : Type -> Type where Caload : Asm () Castore : Asm () Checkcast : (descriptor: String) -> Asm () - ClassCodeStart : Int -> Access -> (className: String) -> (signature: Maybe String) -> (parentClassName: String) -> + ClassCodeStart : Int -> List Access -> (className: String) -> (signature: Maybe String) -> (parentClassName: String) -> (interfaces: List String) -> List Asm.Annotation -> Asm () - CreateClass : ClassOpts -> Asm () + CreateClass : List ClassOpts -> Asm () CreateField : List Access -> (sourceFileName: String) -> (className: String) -> (fieldName: String) -> (descriptor: String) -> - (signature: Maybe String) -> Maybe FieldInitialValue -> Asm () + (signature: Maybe String) -> Maybe FieldInitialValue -> (annotations: List Asm.Annotation) -> Asm () CreateLabel : String -> Asm () CreateMethod : List Access -> (sourceFileName: String) -> (className: String) -> (methodName: String) -> (descriptor: String) -> @@ -636,6 +693,7 @@ data Asm : Type -> Type where Ificmple : (label: String) -> Asm () Ificmplt : (label: String) -> Asm () Ificmpeq : (label: String) -> Asm () + Ifacmpne : (label: String) -> Asm () Ificmpne : (label: String) -> Asm () Ifle : (label: String) -> Asm () Iflt : (label: String) -> Asm () @@ -671,10 +729,10 @@ data Asm : Type -> Type where Lload : Int -> Asm () Lmul : Asm () Lneg : Asm () - Lor : Asm () LocalVariable : (name: String) -> (descriptor: String) -> (signature: Maybe String) -> (startLabel: String) -> (endLabel: String) -> (index: Int) -> Asm () LookupSwitch : (defaultLabel: String) -> (labels: List String) -> (cases: List Int) -> Asm () + Lor : Asm () Lrem : Asm () Lreturn : Asm () Lshl : Asm () @@ -716,11 +774,6 @@ Show Scope where ("childIndices", show $ childIndices scope) ] -export -Show InferredFunctionType where - show inferredFunctionType = - join " -> " $ show <$> (parameterTypes inferredFunctionType ++ [returnType inferredFunctionType]) - export Show Function where show function = @@ -770,9 +823,9 @@ public export newAsmState : HasIO io => AsmGlobalState -> Assembler -> io AsmState newAsmState globalState assembler = do let defaultName = Jqualified "" "" - scopes <- JList.new {a=Scope} + scopes <- ArrayList.new {elemTy=Scope} lineNumberLabels <- Map.newTreeMap {key=Int} {value=String} - let function = MkFunction defaultName (MkInferredFunctionType IUnknown []) scopes + let function = MkFunction defaultName (MkInferredFunctionType IUnknown []) (believe_me scopes) 0 defaultName (NmCrash emptyFC "uninitialized function") pure $ MkAsmState globalState function defaultName 0 0 0 0 lineNumberLabels assembler @@ -825,6 +878,10 @@ export getProgramName : Asm String getProgramName = LiftIo $ AsmGlobalState.getProgramName !getGlobalState +export +getFcAndDefinition : String -> Asm (FC, NamedDef) +getFcAndDefinition name = LiftIo $ AsmGlobalState.getFcAndDefinition !getGlobalState name + export isUntypedFunction : Jname -> Asm Bool isUntypedFunction name = LiftIo $ AsmGlobalState.isUntypedFunction !getGlobalState name @@ -904,23 +961,24 @@ resetScope = updateState $ currentScopeIndex := 0 } -fillNull : HasIO io => Int -> JList a -> io () -fillNull index list = do - size <- JList.size list - nulls <- JList.nCopies (index - size) nullValue - ignore $ JList.addAll list (believe_me nulls) +fillNull : (HasIO io, Inherits list (JList a)) => Int -> list -> io () +fillNull index aList = do + let list = the (JList a) $ believe_me aList + size <- Collection.size {elemTy=a,obj=Collection a} $ believe_me list + nulls <- JList.nCopies {a=a} (index - size) nullValue + ignore $ JList.addAll {a=a, obj=Collection a} list $ believe_me nulls export saveScope : Scope -> Asm () saveScope scope = do scopes <- scopes <$> getCurrentFunction - size <- LiftIo $ JList.size {a=Scope} scopes + size <- LiftIo $ Collection.size {elemTy=Scope, obj=Collection Scope} $ believe_me scopes let scopeIndex = index scope LiftIo $ if scopeIndex < size then ignore $ JList.set scopes scopeIndex scope else do - fillNull scopeIndex scopes + fillNull {a=Scope} scopeIndex scopes JList.add scopes scopeIndex scope export @@ -968,7 +1026,7 @@ getLineNumberLabel lineNumber = do state <- GetState let currentLineNumberLabels = lineNumberLabels state optLabel <- LiftIo $ Map.get {value=String} currentLineNumberLabels lineNumber - case optLabel of + case nullableToMaybe optLabel of Just label => Pure label Nothing => do label <- newLabel @@ -1023,21 +1081,21 @@ generateVariable namePrefix = do namespace JAsmState %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/AsmState" "updateVariableIndices" "java/util/Map java/util/Map" "void" - prim_updateVariableIndices : JMap -> JMap -> PrimIO () + prim_updateVariableIndices : Map key value -> Map key value -> PrimIO () export updateVariableIndices : HasIO io => Map String Int -> Map String Int -> io () updateVariableIndices resultIndicesByName indicesByName = - primIO $ prim_updateVariableIndices (believe_me resultIndicesByName) (believe_me indicesByName) + primIO $ prim_updateVariableIndices resultIndicesByName indicesByName %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/AsmState" "getVariableNames" "java/util/Map" "java/util/List" - prim_getVariableNames : JMap -> PrimIO JListNative + prim_getVariableNames : Map key value -> PrimIO (JList key) export getVariableNames : HasIO io => Map String Int -> io (List String) getVariableNames indicesByName = do - jlist <- primIO $ prim_getVariableNames (believe_me indicesByName) - JList.fromIterable (believe_me jlist) + jlist <- primIO $ prim_getVariableNames indicesByName + JList.fromIterable jlist retrieveVariableIndicesByName : Int -> Asm (Map String Int) retrieveVariableIndicesByName scopeIndex = do @@ -1065,7 +1123,7 @@ retrieveVariableIndexAtScope currentScopeIndex name = go currentScopeIndex where go scopeIndex = do scope <- getScope scopeIndex optIndex <- LiftIo $ Map.get {value=Int} (variableIndices scope) name - case optIndex of + case nullableToMaybe optIndex of Just index => Pure index Nothing => case parentIndex scope of Just parentScopeIndex => go parentScopeIndex @@ -1083,7 +1141,7 @@ retrieveVariableTypeAtScope : Int -> String -> Asm InferredType retrieveVariableTypeAtScope scopeIndex name = do scope <- getScope scopeIndex optTy <- LiftIo $ Map.get (variableTypes scope) name - case optTy of + case nullableToMaybe optTy of Just ty => Pure ty Nothing => case parentIndex scope of Just parentScope => retrieveVariableTypeAtScope parentScope name @@ -1118,7 +1176,7 @@ getVariableIndexAtScope : Int -> String -> Asm Int getVariableIndexAtScope currentScopeIndex name = do variableIndicesByName <- getVariableIndicesByName currentScopeIndex optIndex <- LiftIo $ Map.get {value=Int} variableIndicesByName name - case optIndex of + case nullableToMaybe optIndex of Just index => Pure index Nothing => do rootMethodName <- getRootMethodName @@ -1143,11 +1201,11 @@ getVariableTypeAtScope scopeIndex name = do scope <- getScope scopeIndex variableIndicesByName <- getVariableIndicesByName scopeIndex optIndex <- LiftIo $ Map.get {value=Int} variableIndicesByName name - case optIndex of + case nullableToMaybe optIndex of Just index => do variableTypes <- getVariableTypesAtScope scopeIndex optTy <- LiftIo $ Map.get {value=InferredType} variableTypes index - Pure $ fromMaybe IUnknown optTy + Pure $ fromMaybe IUnknown $ nullableToMaybe optTy Nothing => Pure IUnknown export @@ -1157,7 +1215,7 @@ getVariableType name = getVariableTypeAtScope !getCurrentScopeIndex name updateArgumentsForUntyped : Map Int InferredType -> Nat -> IO () updateArgumentsForUntyped _ Z = pure () updateArgumentsForUntyped types (S n) = do - ignore $ Map.put types (cast n) inferredObjectType + ignore $ Map.put types (cast {to=Int} n) inferredObjectType updateArgumentsForUntyped types n export @@ -1180,7 +1238,7 @@ getVariableScope name = go !getCurrentScopeIndex where go scopeIndex = do scope <- getScope scopeIndex optTy <- LiftIo $ Map.get {value=InferredType} (variableTypes scope) name - case optTy of + case nullableToMaybe optTy of Just _ => Pure scope Nothing => case parentIndex scope of Just parentScopeIndex => go parentScopeIndex @@ -1219,20 +1277,151 @@ getLambdaImplementationMethodName namePrefix = do else namePrefix ++ "$" ++ declaringMethodName ++ "$" ++ show lambdaIndex Pure $ Jqualified lambdaClassName lambdaMethodName +isBoolTySpec : Name -> Bool +isBoolTySpec name = name == basics "Bool" || name == (NS preludeNS (UN $ Basic "Bool")) + +mutual + tySpecFn : String -> InferredFunctionType + tySpecFn desc = case reverse $ toList $ String.split (== '⟶') desc of + [] => assert_total $ idris_crash ("Invalid function type descriptor: " ++ desc) + (returnTypeStr :: argsReversed) => + MkInferredFunctionType (tySpecStr returnTypeStr) (reverse $ (tySpecStr <$> argsReversed)) + + tySpecLambda : String -> JavaLambdaType + tySpecLambda desc = case toList $ String.split (== ',') desc of + [intfStr, method, methodTypeStr, implementationTypeStr] => + MkJavaLambdaType (tySpecStr intfStr) method (tySpecFn methodTypeStr) (tySpecFn implementationTypeStr) + _ => assert_total $ idris_crash ("Invalid lambda type descriptor: " ++ desc) + + tySpecStr : String -> InferredType + tySpecStr "Int" = IInt + tySpecStr "Int8" = IByte + tySpecStr "Int16" = IShort + tySpecStr "Int32" = IInt + tySpecStr "Int64" = ILong + tySpecStr "Integer" = inferredBigIntegerType + tySpecStr "String" = inferredStringType + tySpecStr "Double" = IDouble + tySpecStr "Char" = IChar + tySpecStr "Bool" = IBool + tySpecStr "long" = ILong + tySpecStr "void" = IVoid + tySpecStr "%World" = IInt + tySpecStr "[" = assert_total $ idris_crash "Invalid type descriptor: [" + tySpecStr "λ" = assert_total $ idris_crash "Invalid type descriptor: λ" + tySpecStr desc = + cond [(startsWith desc "[", IArray (tySpecStr (assert_total (strTail desc)))), + (startsWith desc "λ", IFunction (tySpecLambda (assert_total (strTail desc)))) + ] + (iref desc []) + +export +structName : Name +structName = NS (mkNamespace "System.FFI") (UN $ Basic "Struct") + +export +arrayName : Name +arrayName = NS (mkNamespace "Java.Lang") (UN $ Basic "Array") + +getIdrisConstructorType : ConInfo -> (tag: Maybe Int) -> Nat -> Name -> InferredType +getIdrisConstructorType conInfo tag arity name = + if isBoolTySpec name then IBool + else if name == basics "List" then idrisListType + else if name == preludetypes "Maybe" then idrisMaybeType + else if name == preludetypes "Nat" then inferredBigIntegerType + else inferredObjectType + +parseName : String -> Maybe InferredType +parseName name = + case words name of + (interfaceName :: methodName :: _) => Just $ IRef interfaceName Interface [] + (className :: []) => Just $ iref className [] + _ => Nothing + +mutual + parseArrayType : NamedCExp -> Asm (Maybe InferredType) + parseArrayType expr@(NmCon _ name _ _ [elemTy]) = + if name == arrayName then Pure . Just $ IArray !(tySpec elemTy) + else Pure Nothing + parseArrayType _ = Pure Nothing + + parseLambdaType : NamedCExp -> Asm (Maybe InferredType) + parseLambdaType (NmCon _ name _ _ [interfaceType, _]) = + if name == builtin "Pair" then parseJvmReferenceType interfaceType + else Pure Nothing + parseLambdaType _ = Pure Nothing + + parseJvmReferenceType : NamedCExp -> Asm (Maybe InferredType) + parseJvmReferenceType (NmCon _ name _ _ (NmPrimVal _ (Str namePartsStr) :: _)) = + if name == structName + then Pure $ parseName namePartsStr + else Pure Nothing + parseJvmReferenceType (NmCon _ name conInfo tag args) = + if name == primio "IORes" then + maybe (asmCrash "Expected an argument for IORes") (\res => Pure $ Just !(tySpec res)) (head' args) + else Pure $ Just $ getIdrisConstructorType conInfo tag (length args) name + parseJvmReferenceType (NmApp fc (NmRef _ name) _) = do + (_, MkNmFun _ def) <- getFcAndDefinition (jvmSimpleName name) + | _ => asmCrash ("Expected a function returning a tuple containing interface type and method type at " ++ + show fc) + ty <- tySpec def + Pure $ Just ty + parseJvmReferenceType (NmDelay _ _ expr) = Pure $ Just !(tySpec expr) + parseJvmReferenceType expr = Pure Nothing + + tryParse : NamedCExp -> Asm (Maybe InferredType) + tryParse expr = do + arrayTypeMaybe <- parseArrayType expr + case arrayTypeMaybe of + Nothing => do + lambdaTypeMaybe <- parseLambdaType expr + case lambdaTypeMaybe of + Nothing => parseJvmReferenceType expr + Just lambdaType => Pure $ Just lambdaType + Just arrayType => Pure $ Just arrayType + + export + tySpec : NamedCExp -> Asm InferredType + tySpec (NmCon _ (UN (Basic ty)) _ _ []) = Pure $ tySpecStr ty + tySpec (NmCon _ _ NOTHING _ []) = Pure idrisMaybeType + tySpec (NmCon _ _ JUST _ [_]) = Pure idrisMaybeType + tySpec (NmCon _ _ NIL _ []) = Pure idrisListType + tySpec (NmCon _ _ CONS _ [_, _]) = Pure idrisListType + tySpec expr@(NmCon _ (NS _ (UN (Basic "Unit"))) _ _ []) = Pure IVoid + tySpec expr = do + ty <- tryParse expr + Pure $ fromMaybe inferredObjectType ty + export getJvmTypeDescriptor : InferredType -> String -getJvmTypeDescriptor IByte = "B" -getJvmTypeDescriptor IChar = "C" -getJvmTypeDescriptor IShort = "S" -getJvmTypeDescriptor IBool = "Z" -getJvmTypeDescriptor IDouble = "D" -getJvmTypeDescriptor IFloat = "F" -getJvmTypeDescriptor IInt = "I" -getJvmTypeDescriptor ILong = "J" -getJvmTypeDescriptor IVoid = "V" -getJvmTypeDescriptor IUnknown = getJvmTypeDescriptor inferredObjectType -getJvmTypeDescriptor (IRef ty) = "L" ++ ty ++ ";" -getJvmTypeDescriptor (IArray ty) = "[" ++ getJvmTypeDescriptor ty +getJvmTypeDescriptor IByte = "B" +getJvmTypeDescriptor IChar = "C" +getJvmTypeDescriptor IShort = "S" +getJvmTypeDescriptor IBool = "Z" +getJvmTypeDescriptor IDouble = "D" +getJvmTypeDescriptor IFloat = "F" +getJvmTypeDescriptor IInt = "I" +getJvmTypeDescriptor ILong = "J" +getJvmTypeDescriptor IVoid = "V" +getJvmTypeDescriptor (IRef ty _ _) = "L" ++ ty ++ ";" +getJvmTypeDescriptor (IArray ty) = "[" ++ getJvmTypeDescriptor ty +getJvmTypeDescriptor (IFunction lambdaType) = getJvmTypeDescriptor (lambdaType.javaInterface) +getJvmTypeDescriptor IUnknown = getJvmTypeDescriptor inferredObjectType + +export +getJvmReferenceTypeName : InferredType -> Asm String +getJvmReferenceTypeName (IRef ty _ _) = Pure ty +getJvmReferenceTypeName (IArray (IRef ty _ _)) = Pure ("[L" ++ ty ++ ";") +getJvmReferenceTypeName (IArray ty) = Pure ("[" ++ !(getJvmReferenceTypeName ty)) +getJvmReferenceTypeName (IFunction lambdaType) = getJvmReferenceTypeName (lambdaType.javaInterface) +getJvmReferenceTypeName ty = asmCrash ("Expected a reference type but found " ++ show ty) + +export +getSignature : InferredType -> String +getSignature (IRef ty _ typeParams@(_ :: _)) = + let typeParamsDescriptor = concat (getJvmTypeDescriptor <$> typeParams) + in "L" ++ ty ++ "<" ++ typeParamsDescriptor ++ ">;" +getSignature type = getJvmTypeDescriptor type export asmReturn : InferredType -> Asm () @@ -1248,12 +1437,17 @@ asmReturn IDouble = Dreturn asmReturn _ = Areturn export +-- constant values from org.objectweb.asm.Opcodes accessNum : Access -> Int -accessNum Final = 16 -accessNum Private = 2 -accessNum Public = 1 -accessNum Static = 8 -accessNum Synthetic = 4096 +accessNum Public = 0x0001 +accessNum Private = 0x0002 +accessNum Protected = 0x0004 +accessNum Static = 0x0008 +accessNum Final = 0x0010 +accessNum Interface = 0x0200 +accessNum Abstract = 0x0400 +accessNum Synthetic = 0x1000 +accessNum Transient = 0x0080 export fieldInsTypeNum : FieldInstructionType -> Int @@ -1393,19 +1587,19 @@ prim_newJAnnAnnotation : JAnnotation -> PrimIO JAnnAnnotation jvm' "io/github/mmhelloworld/idrisjvm/assembler/AnnotationValue$AnnArray" "" "java/util/List" "io/github/mmhelloworld/idrisjvm/assembler/AnnotationValue$AnnArray" -prim_newJAnnArray : JListNative -> PrimIO JAnnArray +prim_newJAnnArray : JList JAnnotationValue -> PrimIO JAnnArray %foreign - jvm' "io/github/mmhelloworld/idrisjvm/assembler/AnnotationValue$AnnotationProperty" "" + jvm' "io/github/mmhelloworld/idrisjvm/assembler/AnnotationProperty" "" "String io/github/mmhelloworld/idrisjvm/assembler/AnnotationValue" - "io/github/mmhelloworld/idrisjvm/assembler/AnnotationValue$AnnotationProperty" + "io/github/mmhelloworld/idrisjvm/assembler/AnnotationProperty" prim_newJAnnotationProperty : String -> JAnnotationValue -> PrimIO JAnnotationProperty %foreign jvm' "io/github/mmhelloworld/idrisjvm/assembler/Annotation" "" "String java/util/List" "io/github/mmhelloworld/idrisjvm/assembler/Annotation" -prim_newJAnnotation : String -> JListNative -> PrimIO JAnnotation +prim_newJAnnotation : String -> JList JAnnotationProperty -> PrimIO JAnnotation export toJHandle : HasIO io => Handle -> io JHandle @@ -1433,7 +1627,7 @@ mutual jAnn <- toJAnnotation n believe_me <$> primIO (prim_newJAnnAnnotation jAnn) toJAnnotationValue (AnnArray values) = - believe_me <$> primIO (prim_newJAnnArray (believe_me values)) + believe_me <$> primIO (prim_newJAnnArray $ subtyping !(traverse toJAnnotationValue values)) toJAnnotationProperty : HasIO io => Asm.AnnotationProperty -> io JAnnotationProperty toJAnnotationProperty (name, annValue) = do @@ -1441,7 +1635,23 @@ mutual primIO $ prim_newJAnnotationProperty name jAnnotationValue toJAnnotation : HasIO io => Asm.Annotation -> io JAnnotation - toJAnnotation (MkAnnotation name props) = primIO $ prim_newJAnnotation name (believe_me props) + toJAnnotation (MkAnnotation name props) = do + properties <- traverse toJAnnotationProperty props + primIO $ prim_newJAnnotation name $ believe_me properties + +mutual + asmAnnotationValue : AnnotationValue -> AnnotationValue + asmAnnotationValue (AnnArray values) = AnnArray (asmAnnotationValue <$> values) + asmAnnotationValue (AnnAnnotation annotation) = AnnAnnotation (asmAnnotation annotation) + asmAnnotationValue value = value + + asmAnnotationProperty : (String, AnnotationValue) -> (String, AnnotationValue) + asmAnnotationProperty (name, value) = (name, asmAnnotationValue value) + + export + asmAnnotation : Annotation -> Annotation + asmAnnotation (MkAnnotation name properties) = + MkAnnotation ("L" ++ name ++ ";") (asmAnnotationProperty <$> properties) export toJFieldInitialValue : FieldInitialValue -> Object @@ -1468,6 +1678,14 @@ getMethodDescriptor (MkInferredFunctionType retTy argTypes) = retTyDesc = getJvmTypeDescriptor retTy in "(" ++ (the String $ concat argDescs) ++ ")" ++ retTyDesc +export +getMethodSignature : InferredFunctionType -> String +getMethodSignature (MkInferredFunctionType retTy []) = "()" ++ getSignature retTy +getMethodSignature (MkInferredFunctionType retTy argTypes) = + let argDescs = getSignature <$> argTypes + retTyDesc = getSignature retTy + in "(" ++ (the String $ concat argDescs) ++ ")" ++ retTyDesc + export assemble : HasIO io => AsmState -> IO a -> io (a, AsmState) assemble state m = do @@ -1486,12 +1704,6 @@ getIdrisFunctionName programName moduleName idrisFunctionName = (className :: functionName :: _) => Jqualified className functionName _ => Jqualified moduleName idrisFunctionName -export -%foreign - jvm' "io/github/mmhelloworld/idrisjvm/assembler/IdrisName" "getIdrisConstructorClassName" - "String" "String" -getIdrisConstructorClassName : String -> String - %inline metafactoryDesc : String metafactoryDesc = @@ -1526,11 +1738,11 @@ shouldDebug = export debugFunction : String -debugFunction = fromMaybe " " $ unsafePerformIO $ getEnv "IDRIS_JVM_DEBUG" +debugFunction = fromMaybe "" $ unsafePerformIO $ getEnv "IDRIS_JVM_DEBUG" export shouldDebugFunction : Jname -> Bool -shouldDebugFunction jname = shouldDebug && (debugFunction `isInfixOf` (getSimpleName jname)) +shouldDebugFunction jname = shouldDebug && (debugFunction == "" || (debugFunction `isInfixOf` (getSimpleName jname))) namespace LocalDateTime data LocalDateTime : Type where [external] @@ -1554,6 +1766,32 @@ export getCurrentThreadName : HasIO io => io String getCurrentThreadName = primIO prim_getCurrentThreadName +export +getJvmClassMethodName : String -> Name -> Jname +getJvmClassMethodName programName name = + let jname = jvmName name + in getIdrisFunctionName programName (className jname) (methodName jname) + +export +createAsmStateJavaName : AsmGlobalState -> String -> IO AsmState +createAsmStateJavaName globalState name = do + assembler <- getAssembler globalState name + newAsmState globalState assembler + +export +createAsmState : AsmGlobalState -> Name -> IO AsmState +createAsmState globalState name = do + programName <- AsmGlobalState.getProgramName globalState + let jvmClassMethodName = getJvmClassMethodName programName name + createAsmStateJavaName globalState (className jvmClassMethodName) + +%foreign jvm' "io/github/mmhelloworld/idrisjvm/runtime/Runtime" "waitForFuturesToComplete" "java/util/List" "void" +prim_waitForFuturesToComplete : List ThreadID -> PrimIO () + +export +waitForFuturesToComplete : List ThreadID -> IO () +waitForFuturesToComplete futures = primIO $ prim_waitForFuturesToComplete futures + export log : Lazy String -> (result : a) -> a log message val = @@ -1577,17 +1815,31 @@ data FArgList : Type where export %extern prim__jvmInstance : (ret : Type) -> String -> (1 args : FArgList) -> (1 x : %World) -> IORes ret -export -%extern prim__jvmStatic : (ret : Type) -> String -> (1 args : FArgList) -> (1 x : %World) -> IORes ret - -export %inline -jvmStatic : (ret : Type) -> String -> (1 args : FArgList) -> IO ret -jvmStatic ret fn args = fromPrim (prim__jvmStatic ret fn args) - export %inline jvmInstance : (ret : Type) -> String -> (1 args : FArgList) -> IO ret jvmInstance ret fn args = fromPrim (prim__jvmInstance ret fn args) +export +superName : Name +superName = NS (mkNamespace "Java.Lang") (UN $ Basic "super") + +export +isSuperCall : Name -> List NamedCExp -> Bool +isSuperCall name + [(NmExtPrim fc f@(NS ns (UN (Basic "prim__jvmStatic"))) args@(ret :: NmPrimVal primFc (Str fn):: rest))] + = name == superName && endsWith "." fn +isSuperCall _ _ = False + +public export +%inline +methodStartLabel : String +methodStartLabel = "methodStartLabel" + +public export +%inline +methodEndLabel : String +methodEndLabel = "methodEndLabel" + export runAsm : HasIO io => AsmState -> Asm a -> io (a, AsmState) runAsm state Aaload = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.aaload" [assembler state] @@ -1630,17 +1882,18 @@ runAsm state (Checkcast desc) = assemble state $ runAsm state (ClassCodeStart version access className sig parent intf anns) = assemble state $ do janns <- sequence $ toJAnnotation <$> anns jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.classCodeStart" - [assembler state, version, accessNum access, className, maybeToNullable sig, parent, + [assembler state, version, sum $ accessNum <$> access, className, maybeToNullable sig, parent, the (JList String) $ believe_me intf, the (JList JAnnotation) $ believe_me janns] runAsm state (CreateClass opts) = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.createClass" - [assembler state, toJClassOpts opts] -runAsm state (CreateField accs sourceFileName className fieldName desc sig fieldInitialValue) = assemble state $ do + [assembler state, sum $ toJClassOpts <$> opts] +runAsm state (CreateField accs sourceFileName className fieldName desc sig fieldInitialValue anns) = assemble state $ do let jaccs = sum $ accessNum <$> accs + janns <- sequence $ toJAnnotation <$> anns jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.createField" [assembler state, jaccs, sourceFileName, className, fieldName, desc, maybeToNullable sig, - maybeToNullable (toJFieldInitialValue <$> fieldInitialValue)] + maybeToNullable (toJFieldInitialValue <$> fieldInitialValue), the (JList JAnnotation) $ believe_me janns] runAsm state (CreateLabel label) = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.createLabel" [assembler state, label] @@ -1779,6 +2032,8 @@ runAsm state (Ificmplt label) = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.ificmplt" [assembler state, label] runAsm state (Ificmpeq label) = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.ificmpeq" [assembler state, label] +runAsm state (Ifacmpne label) = + assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.ifacmpne" [assembler state, label] runAsm state (Ificmpne label) = assemble state $ jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.ificmpne" [assembler state, label] runAsm state (Ifle label) = diff --git a/src/Compiler/Jvm/Codegen.idr b/src/Compiler/Jvm/Codegen.idr index 59db7f795..cc2a944ca 100644 --- a/src/Compiler/Jvm/Codegen.idr +++ b/src/Compiler/Jvm/Codegen.idr @@ -3,40 +3,42 @@ module Compiler.Jvm.Codegen import Compiler.Common import Compiler.CompileExpr import Compiler.Inline +import Compiler.NoMangle import Core.Context import Core.Directory import Core.Name +import Core.Options import Core.TT import Data.List +import Data.List1 import Data.Maybe -import Libraries.Data.SortedMap import Data.String import Data.Vect -import Core.Directory -import Core.Options -import Libraries.Utils.Path +import Debug.Trace import Libraries.Data.NameMap +import Libraries.Data.SortedMap +import Libraries.Utils.Path import System.File import System.FFI import System.Info import Compiler.Jvm.Asm -import Compiler.Jvm.Math -import Compiler.Jvm.MockAsm -import Compiler.Jvm.Optimizer +import Compiler.Jvm.Export +import Compiler.Jvm.ExtPrim +import Compiler.Jvm.FunctionTree import Compiler.Jvm.InferredType import Compiler.Jvm.Jname -import Compiler.Jvm.Variable -import Compiler.Jvm.Tree -import Compiler.Jvm.FunctionTree -import Compiler.Jvm.ExtPrim +import Compiler.Jvm.Math +import Compiler.Jvm.Optimizer import Compiler.Jvm.ShowUtil +import Compiler.Jvm.Tree import Compiler.Jvm.Tuples +import Compiler.Jvm.Variable import Idris.Syntax @@ -82,14 +84,6 @@ withScope op = do op exitScope scopeIndex -%inline -methodStartLabel : String -methodStartLabel = "methodStartLabel" - -%inline -methodEndLabel : String -methodEndLabel = "methodEndLabel" - defaultValue : InferredType -> Asm () defaultValue IBool = Iconst 0 defaultValue IByte = Iconst 0 @@ -101,6 +95,42 @@ defaultValue IFloat = Fconst 0 defaultValue IDouble = Dconst 0 defaultValue _ = Aconstnull +assembleArray : (elemTy: InferredType) -> Asm () +assembleArray IBool = Anewbooleanarray +assembleArray IByte = Anewbytearray +assembleArray IChar = Anewchararray +assembleArray IShort = Anewshortarray +assembleArray IInt = Anewintarray +assembleArray ILong = Anewlongarray +assembleArray IFloat = Anewfloatarray +assembleArray IDouble = Anewdoublearray +assembleArray (IRef ty _ _) = Anewarray ty +assembleArray (IArray ty) = Anewarray (getJvmTypeDescriptor ty) +assembleArray (IFunction (MkJavaLambdaType (IRef ty _ _) _ _ _)) = Anewarray ty +assembleArray _ = Anewarray "java/lang/Object" + +storeArray : (elemTy: InferredType) -> Asm () +storeArray IBool = Bastore +storeArray IByte = Bastore +storeArray IChar = Castore +storeArray IShort = Sastore +storeArray IInt = Iastore +storeArray ILong = Lastore +storeArray IFloat = Fastore +storeArray IDouble = Dastore +storeArray _ = Aastore + +loadArray : (elemTy: InferredType) -> Asm () +loadArray IBool = Baload +loadArray IByte = Baload +loadArray IChar = Caload +loadArray IShort = Saload +loadArray IInt = Iaload +loadArray ILong = Laload +loadArray IFloat = Faload +loadArray IDouble = Daload +loadArray _ = Aaload + jIntKind : PrimType -> IntKind jIntKind ty = fromMaybe (Signed (P 32)) (intKind ty) @@ -135,8 +165,8 @@ hashCode (Str value) = Just $ Object.hashCode value hashCode x = Nothing getHashCodeSwitchClass : FC -> InferredType -> Asm String -getHashCodeSwitchClass fc (IRef "java/lang/String") = Pure stringClass -getHashCodeSwitchClass fc (IRef "java/math/BigInteger") = Pure bigIntegerClass +getHashCodeSwitchClass fc (IRef "java/lang/String" _ _) = Pure stringClass +getHashCodeSwitchClass fc (IRef "java/math/BigInteger" _ _) = Pure bigIntegerClass getHashCodeSwitchClass fc ILong = Pure "java/lang/Long" getHashCodeSwitchClass fc constantType = asmCrash ("Constant type " ++ show constantType ++ " cannot be compiled to 'Switch'.") @@ -208,12 +238,9 @@ assembleBits64 isTailCall returnType value = do when isTailCall $ asmReturn returnType isInterfaceInvocation : InferredType -> Bool -isInterfaceInvocation (IRef className) = "i:" `isPrefixOf` className +isInterfaceInvocation (IRef _ Interface _) = True isInterfaceInvocation _ = False -%foreign "jvm:.startsWith(java/lang/String java/lang/String boolean),java/lang/String" -startsWith : String -> String -> Bool - assembleNil : (isTailCall: Bool) -> InferredType -> Asm () assembleNil isTailCall returnType = do Field GetStatic idrisNilClass "INSTANCE" "Lio/github/mmhelloworld/idrisjvm/runtime/IdrisList$Nil;" @@ -264,6 +291,18 @@ getLambdaTypeByArity 4 = Function4Lambda getLambdaTypeByArity 5 = Function5Lambda getLambdaTypeByArity _ = FunctionLambda +assembleClassLiteral : InferredType -> Asm () +assembleClassLiteral IByte = Field GetStatic "java/lang/Byte" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IChar = Field GetStatic "java/lang/Character" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IShort = Field GetStatic "java/lang/Short" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IBool = Field GetStatic "java/lang/Boolean" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IDouble = Field GetStatic "java/lang/Double" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IFloat = Field GetStatic "java/lang/Float" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IInt = Field GetStatic "java/lang/Integer" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral ILong = Field GetStatic "java/lang/Long" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral IVoid = Field GetStatic "java/lang/Void" "TYPE" "Ljava/lang/Class;" +assembleClassLiteral type = Ldc $ TypeConst $ getJvmTypeDescriptor type + intToBigInteger : Asm () intToBigInteger = do I2l @@ -338,7 +377,9 @@ mutual assembleExpr isTailCall returnType (NmApp _ (NmRef _ idrisName) []) = assembleNmAppNilArity isTailCall returnType idrisName - assembleExpr isTailCall returnType (NmApp _ (NmRef _ idrisName) args) = do + assembleExpr isTailCall returnType (NmApp _ (NmRef _ idrisName) args) = + if isSuperCall idrisName args then do Aconstnull; when isTailCall $ asmReturn returnType + else do let jname = jvmName idrisName functionType <- case !(findFunctionType jname) of Just ty => Pure ty @@ -561,7 +602,7 @@ mutual assembleExprComparableBinaryBoolOp : InferredType -> String -> (String -> Asm ()) -> NamedCExp -> NamedCExp -> Asm () assembleExprComparableBinaryBoolOp returnType className operator expr1 expr2 = do - let exprType = IRef className + let exprType = IRef className Class [] assembleExpr False exprType expr1 assembleExpr False exprType expr2 ifLabel <- newLabel @@ -1209,7 +1250,7 @@ mutual when (lambdaType == DelayedLambda) $ do New "io/github/mmhelloworld/idrisjvm/runtime/MemoizedDelayed" Dup - let lambdaInterfaceType = getLambdaInterfaceType lambdaType lambdaBodyReturnType + let lambdaInterfaceType = getLambdaInterfaceType lambdaType parameterType <- the (Asm (Maybe InferredType)) $ traverse getVariableType (jvmSimpleName <$> parameterName) variableTypes <- LiftIo $ Map.values {key=Int} !(loadClosures declaringScope scope) maybe (Pure ()) id parameterValueExpr @@ -1241,7 +1282,6 @@ mutual let oldLineNumberLabels = lineNumberLabels !GetState newLineNumberLabels <- LiftIo $ Map.newTreeMap {key=Int} {value=String} updateState $ { lineNumberLabels := newLineNumberLabels } - className <- getClassName let accessModifiers = if isExtracted then [Public, Static] else [Public, Static, Synthetic] CreateMethod accessModifiers "" lambdaClassName lambdaMethodName implementationMethodDescriptor Nothing Nothing [] [] @@ -1284,7 +1324,7 @@ mutual loadVariables _ _ [] = Pure () loadVariables declaringScopeVariableTypes types (var :: vars) = do sourceTargetTypeEntry <- LiftIo $ Map.get types var - (sourceType, targetType) <- LiftIo $ readSourceTargetType sourceTargetTypeEntry + (sourceType, targetType) <- LiftIo $ readSourceTargetType $ nullableToMaybe sourceTargetTypeEntry loadVar declaringScopeVariableTypes sourceType targetType var loadVariables declaringScopeVariableTypes types vars @@ -1471,7 +1511,7 @@ mutual let constructorType = if hasTypeCase then "Ljava/lang/String;" else "I" variableTypes <- getVariableTypes optTy <- LiftIo $ Map.get variableTypes idrisObjectVariableIndex - let idrisObjectVariableType = fromMaybe IUnknown optTy + let idrisObjectVariableType = fromMaybe IUnknown $ nullableToMaybe optTy loadVar variableTypes idrisObjectVariableType idrisObjectType idrisObjectVariableIndex when (idrisObjectVariableType /= idrisObjectType) $ do storeVar idrisObjectType idrisObjectType idrisObjectVariableIndex @@ -1486,7 +1526,7 @@ mutual assembleConCaseExpr returnType idrisObjectVariableIndex args expr = do variableTypes <- getVariableTypes optTy <- LiftIo $ Map.get variableTypes idrisObjectVariableIndex - let idrisObjectVariableType = fromMaybe IUnknown optTy + let idrisObjectVariableType = fromMaybe IUnknown $ nullableToMaybe optTy bindArg idrisObjectVariableType variableTypes 0 args assembleExpr True returnType expr where @@ -1584,7 +1624,7 @@ mutual assembleExpr False IInt (NmLocal fc $ UN $ Basic hashCodePositionVariableName) assembleConstructorSwitch returnType fc idrisObjectVariableIndex (hashPositionSwitchAlts hashPositionAndAlts) def - where + where conAltHashCodeExpr : FC -> (Int, NamedConAlt) -> Asm (Int, Int, NamedConAlt) conAltHashCodeExpr fc positionAndAlt@(position, MkNConAlt name _ _ _ _) = case hashCode (Str $ getIdrisConstructorClassName (jvmSimpleName name)) of @@ -1626,6 +1666,79 @@ mutual switchBody label nextLabel position alt go nextLabel positionAndAlts + asmJavaLambda : FC -> InferredType -> NamedCExp -> NamedCExp -> NamedCExp -> Asm () + asmJavaLambda fc returnType functionType javaInterfaceType lambda = do + assembleExpr False inferredLambdaType lambda + lambdaType <- getJavaLambdaType fc [functionType, javaInterfaceType, lambda] + let samType = + if isIoAction then {parameterTypes $= dropWorldType} lambdaType.methodType else lambdaType.methodType + let lambdaImplementationType = lambdaType.implementationType + let lambdaImplementationType = updateImplementationType samType.returnType lambdaImplementationType + let invokeDynamicType = MkInferredFunctionType lambdaType.javaInterface [inferredLambdaType] + let invokeDynamicDescriptor = getMethodDescriptor invokeDynamicType + let implementationParameterTypes = lambdaImplementationType.parameterTypes + let implementationMethodType = MkInferredFunctionType lambdaImplementationType.returnType + (inferredLambdaType :: implementationParameterTypes) + let implementationMethodDescriptor = getMethodDescriptor implementationMethodType + let instantiatedMethodDescriptor = getMethodDescriptor lambdaImplementationType + lambdaClassMethodName <- getLambdaImplementationMethodName "lambda" + let lambdaMethodName = methodName lambdaClassMethodName + let lambdaClassName = className lambdaClassMethodName + invokeDynamic lambdaClassName lambdaMethodName lambdaType.methodName invokeDynamicDescriptor + (getMethodDescriptor samType) implementationMethodDescriptor instantiatedMethodDescriptor + asmCast lambdaType.javaInterface returnType + let accessModifiers = [Public, Static, Synthetic] + CreateMethod accessModifiers "" lambdaClassName lambdaMethodName implementationMethodDescriptor + Nothing Nothing [] [] + MethodCodeStart + Aload 0 + let arity = (cast {to=Int} $ length implementationParameterTypes) + 1 + typesByIndex <- LiftIo $ Map.fromList $ zip [0 .. arity - 1] + (inferredLambdaType :: implementationParameterTypes) + applyParameters typesByIndex 1 lambdaImplementationType.returnType implementationParameterTypes + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + where + isIoAction : Bool + isIoAction = Optimizer.isIoAction functionType + + dropWorldType : List InferredType -> List InferredType + dropWorldType [] = [] + dropWorldType parameterTypes@(_ :: _) = init parameterTypes + + updateImplementationType : InferredType -> InferredFunctionType -> InferredFunctionType + updateImplementationType IVoid functionType = + if isIoAction + then {returnType := IVoid, parameterTypes $= dropWorldType} functionType + else {returnType := IVoid} functionType + updateImplementationType _ functionType = + if isIoAction then {parameterTypes $= dropWorldType} functionType else functionType + + applyParameter : Map Int InferredType -> (isIoApplication: Bool) -> Int -> InferredType -> Asm () + applyParameter typesByIndex isIoApplication index parameterType = do + loadArgument + InvokeMethod InvokeInterface "java/util/function/Function" "apply" "(Ljava/lang/Object;)Ljava/lang/Object;" True + InvokeMethod InvokeStatic runtimeClass "unwrap" "(Ljava/lang/Object;)Ljava/lang/Object;" False + where + loadArgument : Asm () + loadArgument = + if isIoApplication + then do + Iconst 0 + InvokeMethod InvokeStatic "java/lang/Integer" "valueOf" "(I)Ljava/lang/Integer;" False + else loadVar typesByIndex parameterType inferredObjectType index + + applyParameters : Map Int InferredType -> Int -> InferredType -> List InferredType -> Asm () + applyParameters typesByIndex index returnType [] = do + when isIoAction $ applyParameter typesByIndex True index inferredObjectType + asmCast inferredObjectType returnType + when (returnType == IVoid) Pop + asmReturn returnType + applyParameters typesByIndex index returnType (ty :: rest) = do + applyParameter typesByIndex False index ty + when (rest /= [] || isIoAction) $ asmCast inferredObjectType inferredLambdaType + applyParameters typesByIndex (index + 1) returnType rest + jvmExtPrim : FC -> InferredType -> ExtPrim -> List NamedCExp -> Asm () jvmExtPrim fc returnType JvmInstanceMethodCall [ret, NmApp _ _ [functionNamePrimVal], fargs, world] = jvmExtPrim fc returnType JvmInstanceMethodCall [ret, functionNamePrimVal, fargs, world] @@ -1635,32 +1748,81 @@ mutual argTypes <- traverse tySpec (map fst instanceMethodArgs) methodReturnType <- tySpec ret let (cname, mnameWithDot) = break (== '.') fn - traverse_ assembleParameter $ zip (snd obj :: map snd instanceMethodArgs) (IRef cname :: argTypes) - let methodDescriptor = getMethodDescriptor $ MkInferredFunctionType methodReturnType argTypes + traverse_ assembleParameter $ zip (snd obj :: map snd instanceMethodArgs) (iref cname [] :: argTypes) let (_, mname) = break (/= '.') mnameWithDot instanceType <- tySpec $ fst obj let isInterfaceInvocation = isInterfaceInvocation instanceType let invocationType = if isInterfaceInvocation then InvokeInterface else InvokeVirtual + let methodDescriptor = getMethodDescriptor $ MkInferredFunctionType methodReturnType argTypes InvokeMethod invocationType cname mname methodDescriptor isInterfaceInvocation asmCast methodReturnType returnType + jvmExtPrim fc returnType JvmSuper [clazz, fargs, world] = do + rootMethodName <- getRootMethodName + if endsWith (methodName rootMethodName) "$ltinit$gt" + then + do + IRef typeName _ _ <- tySpec clazz + | _ => asmCrash ("super constructor should be called with a reference type but got " ++ show clazz) + let functionNamePrimVal = NmPrimVal fc (Str (typeName ++ "." ++ "")) + jvmExtPrim fc returnType JvmStaticMethodCall [NmErased fc, functionNamePrimVal, fargs, world] + else Aconstnull jvmExtPrim fc returnType JvmStaticMethodCall [ret, NmApp _ _ [functionNamePrimVal], fargs, world] = jvmExtPrim fc returnType JvmStaticMethodCall [ret, functionNamePrimVal, fargs, world] jvmExtPrim _ returnType JvmStaticMethodCall [ret, NmPrimVal fc (Str fn), fargs, world] = do args <- getFArgs fargs argTypes <- traverse tySpec (map fst args) - methodReturnType <- tySpec ret let (cname, mnameWithDot) = break (== '.') fn let (_, mname) = break (/= '.') mnameWithDot let isConstructor = mname == "" when isConstructor $ do New cname Dup + let isSuper = mname == "" + when isSuper $ Aload 0 traverse_ assembleParameter $ zip (map snd args) argTypes + methodReturnType <- if isSuper then Pure IVoid else tySpec ret let descriptorReturnType = if isConstructor then IVoid else methodReturnType let methodDescriptor = getMethodDescriptor $ MkInferredFunctionType descriptorReturnType argTypes - let invocationType = if isConstructor then InvokeSpecial else InvokeStatic + let invocationType = if isConstructor || isSuper then InvokeSpecial else InvokeStatic + let mname = if isSuper then "" else mname InvokeMethod invocationType cname mname methodDescriptor False asmCast methodReturnType returnType + jvmExtPrim _ returnType SetInstanceField [ret, NmPrimVal fc (Str fn), fargs, world] = do + (obj :: value :: []) <- getFArgs fargs + | _ => asmCrash ("Setting an instance field should have two arguments for " ++ fn) + fieldType <- tySpec (fst value) + let (cname, fnameWithDot) = break (== '.') fn + assembleExpr False (iref cname []) (snd obj) + assembleExpr False fieldType (snd value) + let (_, fieldName) = break (\c => c /= '.' && c /= '#' && c /= '=') fnameWithDot + Field PutField cname fieldName (getJvmTypeDescriptor fieldType) + Aconstnull + asmCast inferredObjectType returnType + jvmExtPrim _ returnType SetStaticField [ret, NmPrimVal fc (Str fn), fargs, world] = do + (value :: []) <- getFArgs fargs + | _ => asmCrash ("Setting a static field should have one argument for " ++ fn) + fieldType <- tySpec (fst value) + let (cname, fnameWithDot) = break (== '.') fn + assembleExpr False fieldType (snd value) + let (_, fieldName) = break (\c => c /= '.' && c /= '#' && c /= '=') fnameWithDot + Field PutStatic cname fieldName (getJvmTypeDescriptor fieldType) + Aconstnull + asmCast inferredObjectType returnType + jvmExtPrim _ returnType GetInstanceField [ret, NmPrimVal fc (Str fn), fargs, world] = do + (obj :: []) <- getFArgs fargs + | _ => asmCrash ("Getting an instance field should have one argument for " ++ fn) + fieldType <- tySpec ret + let (cname, fnameWithDot) = break (== '.') fn + assembleExpr False (iref cname []) (snd obj) + let (_, fieldName) = break (\c => c /= '.' && c /= '#') fnameWithDot + Field GetField cname fieldName (getJvmTypeDescriptor fieldType) + asmCast fieldType returnType + jvmExtPrim _ returnType GetStaticField [ret, NmPrimVal fc (Str fn), fargs, world] = do + fieldType <- tySpec ret + let (cname, fnameWithDot) = break (== '.') fn + let (_, fieldName) = break (\c => c /= '.' && c /= '#') fnameWithDot + Field GetStatic cname fieldName (getJvmTypeDescriptor fieldType) + asmCast fieldType returnType jvmExtPrim _ returnType NewArray [_, size, val, world] = do assembleExpr False IInt size assembleExpr False IUnknown val @@ -1677,6 +1839,30 @@ mutual assembleExpr False IUnknown val InvokeMethod InvokeVirtual arrayListClass "set" "(ILjava/lang/Object;)Ljava/lang/Object;" False asmCast inferredObjectType returnType + jvmExtPrim _ returnType JvmNewArray [tyExpr, size, world] = do + assembleExpr False IInt size + elemTy <- tySpec tyExpr + assembleArray elemTy + asmCast (IArray elemTy) returnType + jvmExtPrim _ returnType JvmSetArray [tyExpr, index, val, arr, world] = do + elemTy <- tySpec tyExpr + assembleExpr False (IArray elemTy) arr + assembleExpr False IInt index + assembleExpr False elemTy val + storeArray elemTy + Aconstnull + asmCast inferredObjectType returnType + jvmExtPrim _ returnType JvmGetArray [tyExpr, index, arr, world] = do + elemTy <- tySpec tyExpr + assembleExpr False (IArray elemTy) arr + assembleExpr False IInt index + loadArray elemTy + asmCast elemTy returnType + jvmExtPrim _ returnType JvmArrayLength [tyExpr, arr] = do + elemTy <- tySpec tyExpr + assembleExpr False (IArray elemTy) arr + Arraylength + asmCast IInt returnType jvmExtPrim _ returnType NewIORef [_, val, world] = do New refClass Dup @@ -1703,6 +1889,18 @@ mutual Ldc $ StringConst "Error: Executed 'void'" InvokeMethod InvokeStatic runtimeClass "crash" "(Ljava/lang/String;)Ljava/lang/Object;" False asmCast inferredObjectType returnType + jvmExtPrim _ returnType JvmClassLiteral [ty] = do + assembleClassLiteral !(tySpec ty) + asmCast (IRef "java/lang/Class" Class []) returnType + jvmExtPrim _ returnType JvmInstanceOf [_, obj, ty] = do + assembleExpr False IUnknown obj + typeName <- getJvmReferenceTypeName !(tySpec ty) + InstanceOf typeName + asmCast IBool returnType + jvmExtPrim _ returnType JvmRefEq [_, _, firstObj, secondObj] = + assembleExprBinaryBoolOp returnType IUnknown Ifacmpne firstObj secondObj + jvmExtPrim fc returnType JavaLambda [functionType, javaInterfaceType, lambda] = + asmJavaLambda fc returnType functionType javaInterfaceType lambda jvmExtPrim _ returnType MakeFuture [_, action] = do assembleExpr False delayedType action InvokeMethod InvokeStatic runtimeClass "fork" "(Lio/github/mmhelloworld/idrisjvm/runtime/Delayed;)Ljava/util/concurrent/ForkJoinTask;" False @@ -1711,6 +1909,17 @@ mutual jvmExtPrim fc _ prim args = Throw fc $ "Unsupported external function " ++ show prim ++ "(" ++ (show $ showNamedCExp 0 <$> args) ++ ")" +initializeFunctionState : Asm () +initializeFunctionState = do + lineNumberLabels <- LiftIo $ Map.newTreeMap {key=Int} {value=String} + updateState $ { + scopeCounter := 0, + currentScopeIndex := 0, + lambdaCounter := 0, + labelCounter := 1, + lineNumberLabels := lineNumberLabels } + updateCurrentFunction $ { dynamicVariableCounter := 0 } + assembleDefinition : Name -> FC -> Asm () assembleDefinition idrisName fc = do let jname = jvmName idrisName @@ -1723,14 +1932,7 @@ assembleDefinition idrisName fc = do let declaringClassName = className jvmClassAndMethodName let methodName = methodName jvmClassAndMethodName let methodReturnType = returnType functionType - lineNumberLabels <- LiftIo $ Map.newTreeMap {key=Int} {value=String} - updateState $ { - scopeCounter := 0, - currentScopeIndex := 0, - lambdaCounter := 0, - labelCounter := 1, - lineNumberLabels := lineNumberLabels } - updateCurrentFunction $ { dynamicVariableCounter := 0 } + initializeFunctionState let optimizedExpr = optimizedBody function when (shouldDebugFunction jname) $ logAsm $ "Assembling " ++ declaringClassName ++ "." ++ methodName ++ "\n" ++ showNamedCExp 0 optimizedExpr @@ -1741,7 +1943,7 @@ assembleDefinition idrisName fc = do let classInitOrMethodName = if isField then "" else methodName when isField $ do CreateField [Public, Static, Final] fileName declaringClassName methodName - "Lio/github/mmhelloworld/idrisjvm/runtime/MemoizedDelayed;" Nothing Nothing + "Lio/github/mmhelloworld/idrisjvm/runtime/MemoizedDelayed;" Nothing Nothing [] FieldEnd CreateMethod [Public, Static] fileName declaringClassName classInitOrMethodName descriptor Nothing Nothing [] [] if (not isField) @@ -1771,8 +1973,7 @@ createMainMethod programName mainFunctionName = do function <- getFunction mainFunctionName let idrisMainClassMethodName = jvmClassMethodName function let mainClassName = className idrisMainClassMethodName - CreateMethod [Public, Static] "Main.idr" mainClassName "main" "([Ljava/lang/String;)V" - Nothing Nothing [] [] + CreateMethod [Public, Static] "Main.idr" mainClassName "main" "([Ljava/lang/String;)V" Nothing Nothing [] [] MethodCodeStart Ldc $ StringConst programName Aload 0 @@ -1784,20 +1985,6 @@ createMainMethod programName mainFunctionName = do MaxStackAndLocal (-1) (-1) MethodCodeEnd -asm : AsmState -> Asm a -> IO (a, AsmState) -asm = if shouldDebugAsm then mockRunAsm else runAsm - -getJvmClassMethodName : String -> Name -> Jname -getJvmClassMethodName programName name = - let jname = jvmName name - in getIdrisFunctionName programName (className jname) (methodName jname) - -%foreign jvm' "io/github/mmhelloworld/idrisjvm/runtime/Runtime" "waitForFuturesToComplete" "java/util/List" "void" -prim_waitForFuturesToComplete : List ThreadID -> PrimIO () - -waitForFuturesToComplete : List ThreadID -> IO () -waitForFuturesToComplete futures = primIO $ prim_waitForFuturesToComplete futures - groupByClassName : String -> List Name -> List (List Name) groupByClassName programName names = unsafePerformIO $ do namesByClassName <- Map.newTreeMap {key=String} {value=List Name} @@ -1811,29 +1998,22 @@ groupByClassName programName names = unsafePerformIO $ do go2 (name :: names) = do let jvmClassName = className $ getJvmClassMethodName programName name existingNamesOpt <- Map.get namesByClassName jvmClassName - let newNames = maybe [name] ((::) name) existingNamesOpt + let newNames = maybe [name] ((::) name) $ nullableToMaybe existingNamesOpt _ <- Map.put {key=String} {value=List Name} namesByClassName jvmClassName newNames go2 names -createAsmState : AsmGlobalState -> Name -> IO AsmState -createAsmState globalState name = do - programName <- AsmGlobalState.getProgramName globalState - let jvmClassMethodName = getJvmClassMethodName programName name - assembler <- getAssembler globalState (className jvmClassMethodName) - newAsmState globalState assembler - assemble : AsmGlobalState -> Map String (FC, NamedDef) -> Name -> IO () assemble globalState fcAndDefinitionsByName name = do fcDef <- Map.get {value=(FC, NamedDef)} fcAndDefinitionsByName (jvmSimpleName name) - case fcDef of + case nullableToMaybe fcDef of Just (fc, def) => do programName <- AsmGlobalState.getProgramName globalState asmState <- createAsmState globalState name ignore $ asm asmState $ do inferDef programName name fc def assembleDefinition name fc - scopes <- LiftIo $ JList.new {a=Scope} - updateCurrentFunction $ { scopes := scopes, optimizedBody := emptyFunction } + scopes <- LiftIo $ ArrayList.new {elemTy=Scope} + updateCurrentFunction $ { scopes := (subtyping scopes), optimizedBody := emptyFunction } Nothing => pure () assembleAsync : AsmGlobalState -> Map String (FC, NamedDef) -> List (List Name) -> IO () @@ -1856,10 +2036,445 @@ isForeignDef : (Name, FC, NamedDef) -> Bool isForeignDef (_, _, MkNmForeign _ _ _) = True isForeignDef _ = False +exportConstructor : Map Int InferredType -> InferredType -> Int -> Jname -> Name -> InferredFunctionType -> Asm () +exportConstructor jvmArgumentTypesByIndex jvmReturnType arity jvmIdrisName idrisName idrisFunctionType = do + function <- getCurrentFunction + initializeFunctionState + let optimizedExpr = optimizedBody function + let internalJname = function.idrisName + when (shouldDebugFunction internalJname) $ logAsm $ "Assembling " ++ (className internalJname) ++ "." ++ + (methodName internalJname) ++ "\n" ++ showNamedCExp 0 optimizedExpr + CreateLabel methodStartLabel + CreateLabel methodEndLabel + LabelStart methodStartLabel + withScope $ do + scopeIndex <- getCurrentScopeIndex + scope <- getScope scopeIndex + let (lineNumberStart, lineNumberEnd) = lineNumbers scope + addLineNumber lineNumberStart methodStartLabel + updateScopeStartLabel scopeIndex methodStartLabel + updateScopeEndLabel scopeIndex methodEndLabel + assembleExpr False IVoid (optimizedBody function) + loadArguments jvmArgumentTypesByIndex idrisName arity (parameterTypes idrisFunctionType) + let idrisMethodDescriptor = getMethodDescriptor idrisFunctionType + programName <- getProgramName + let qualifiedJvmIdrisName = getIdrisFunctionName programName (className jvmIdrisName) (methodName jvmIdrisName) + InvokeMethod InvokeStatic + (className qualifiedJvmIdrisName) (methodName qualifiedJvmIdrisName) idrisMethodDescriptor False + InvokeMethod InvokeStatic (programName ++ "/PrimIO") "unsafePerformIO" "(Ljava/lang/Object;)Ljava/lang/Object;" False + asmCast (returnType idrisFunctionType) jvmReturnType + asmReturn jvmReturnType + LabelStart methodEndLabel + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +exportFunction : MethodExport -> Asm () +exportFunction (MkMethodExport jvmFunctionName idrisName type shouldPerformIO encloser modifiers annotations parameterAnnotations) = do + let jvmClassName = encloser.name + let fileName = fst $ getSourceLocationFromFc emptyFC + let MkInferredFunctionType jvmReturnType jvmArgumentTypes = type + let arity = length jvmArgumentTypes + let arityInt = the Int $ cast $ length jvmArgumentTypes + jvmArgumentTypesByIndex <- LiftIo $ Map.fromList $ zip [0 .. (arityInt - 1)] jvmArgumentTypes + let isInstance = not $ elem Static modifiers + jvmArgumentTypesForSignature <- adjustArgumentsForInstanceMember idrisName isInstance jvmArgumentTypes + let functionType = MkInferredFunctionType jvmReturnType jvmArgumentTypesForSignature + let exportedFieldName = jvmFunctionName + let simpleIdrisName = dropAllNS idrisName + let asmAnnotations = asmAnnotation <$> annotations + let asmParameterAnnotations = (\annotations => asmAnnotation <$> annotations) <$> parameterAnnotations + let descriptor = getMethodDescriptor functionType + let signature = Just $ getMethodSignature functionType + CreateMethod modifiers fileName jvmClassName jvmFunctionName descriptor signature Nothing asmAnnotations + asmParameterAnnotations + MethodCodeStart + (_, MkNmFun idrisFunctionArgs idrisFunctionBody) <- getFcAndDefinition (jvmSimpleName idrisName) + | _ => asmCrash ("Unknown idris function " ++ show idrisName) + let idrisFunctionArity = length idrisFunctionArgs + let idrisArgumentTypes = replicate idrisFunctionArity inferredObjectType + let idrisFunctionType = MkInferredFunctionType inferredObjectType idrisArgumentTypes + let jvmIdrisName = jvmName idrisName + let isField = idrisFunctionArity == 0 + let isConstructor = jvmFunctionName == "" + if isConstructor + then exportConstructor jvmArgumentTypesByIndex jvmReturnType arityInt jvmIdrisName idrisName idrisFunctionType + else if not isField then do + loadArguments jvmArgumentTypesByIndex idrisName arityInt (parameterTypes idrisFunctionType) + let idrisMethodDescriptor = getMethodDescriptor idrisFunctionType + programName <- getProgramName + let qualifiedJvmIdrisName = getIdrisFunctionName programName (className jvmIdrisName) + (methodName jvmIdrisName) + InvokeMethod InvokeStatic + (className qualifiedJvmIdrisName) (methodName qualifiedJvmIdrisName) idrisMethodDescriptor False + when shouldPerformIO $ + InvokeMethod InvokeStatic (programName ++ "/PrimIO") "unsafePerformIO" + "(Ljava/lang/Object;)Ljava/lang/Object;" False + asmCast (returnType idrisFunctionType) jvmReturnType + asmReturn jvmReturnType + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + else do + programName <- getProgramName + let qualifiedJvmIdrisName = getIdrisFunctionName programName (className jvmIdrisName) + (methodName jvmIdrisName) + Field GetStatic (className qualifiedJvmIdrisName) (methodName qualifiedJvmIdrisName) + "Lio/github/mmhelloworld/idrisjvm/runtime/MemoizedDelayed;" + InvokeMethod InvokeVirtual "io/github/mmhelloworld/idrisjvm/runtime/MemoizedDelayed" "evaluate" + "()Ljava/lang/Object;" False + asmCast inferredObjectType jvmReturnType + asmReturn jvmReturnType + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +exportField : FieldExport -> Asm () +exportField (MkFieldExport fieldName type encloser modifiers annotations) = do + let jvmClassName = encloser.name + let asmAnnotations = asmAnnotation <$> annotations + CreateField modifiers "Unknown.idr" jvmClassName fieldName (getJvmTypeDescriptor type) Nothing Nothing asmAnnotations + FieldEnd + +exportClass : ClassExport -> Asm () +exportClass (MkClassExport name idrisName extends implements modifiers annotations) = do + CreateClass [ComputeMaxs, ComputeFrames] + let annotations = filter (not . isIdrisJvmAnnotation) annotations + let signature = getSignature extends ++ concat (getSignature <$> implements) + extendsTypeName <- getJvmReferenceTypeName extends + implementsTypeNames <- traverse getJvmReferenceTypeName implements + let asmAnnotations = asmAnnotation <$> annotations + ClassCodeStart 52 modifiers name (Just signature) extendsTypeName implementsTypeNames asmAnnotations + +generateAccessors : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> + (accessorCreator: FieldExport -> Asm ()) -> Asm () +generateAccessors descriptorsByEncloser classExport accessorCreator = do + let className = classExport.name + let fields = getFields $ fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + traverse_ accessorCreator fields + +generateGetters : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateGetters descriptorsByEncloser classExport = + generateAccessors descriptorsByEncloser classExport (createGetter classExport) + +generateSetters : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateSetters descriptorsByEncloser classExport = + generateAccessors descriptorsByEncloser classExport (createSetter classExport) + +generateConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> + List FieldExport -> Asm () +generateConstructor descriptorsByEncloser classExport fields = do + let fieldTypes = FieldExport.type <$> fields + let descriptor = getMethodDescriptor $ MkInferredFunctionType IVoid fieldTypes + let signature = Just $ getMethodSignature $ MkInferredFunctionType IVoid fieldTypes + let classType = iref classExport.name [] + extendsTypeName <- getJvmReferenceTypeName classExport.extends + let arity = the Int $ cast $ length fields + jvmArgumentTypesByIndex <- LiftIo $ Map.fromList $ zip [0 .. arity] (classType :: fieldTypes) + CreateMethod [Public] "generated.idr" classExport.name "" descriptor signature Nothing [] [] + MethodCodeStart + CreateLabel methodStartLabel + CreateLabel methodEndLabel + LabelStart methodStartLabel + Aload 0 + InvokeMethod InvokeSpecial extendsTypeName "" "()V" False + assignFields jvmArgumentTypesByIndex fields + Return + LabelStart methodEndLabel + LocalVariable "this" (getJvmTypeDescriptor classType) Nothing methodStartLabel methodEndLabel 0 + traverse_ (uncurry addLocalVariable) $ zip [1 .. arity] fields + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + where + assignField : Map Int InferredType -> Int -> FieldExport -> Asm () + assignField jvmArgumentTypesByIndex varIndex field = do + let fieldType = field.type + Aload 0 + loadVar jvmArgumentTypesByIndex fieldType fieldType varIndex + Field PutField classExport.name field.name (getJvmTypeDescriptor fieldType) + + assignFields : Map Int InferredType -> List FieldExport -> Asm () + assignFields jvmArgumentTypesByIndex fieldExports = do + let arity = the Int $ cast $ length fieldExports + let varIndexAndExports = zip [1 .. arity] fieldExports + traverse_ (uncurry $ assignField jvmArgumentTypesByIndex) varIndexAndExports + + addLocalVariable : Int -> FieldExport -> Asm () + addLocalVariable index field = do + let fieldType = field.type + LocalVariable field.name (getJvmTypeDescriptor fieldType) Nothing methodStartLabel methodEndLabel index + +generateRequiredArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateRequiredArgsConstructor descriptorsByEncloser classExport = do + let allFields = getFields $ fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + let requiredFields = filter isRequiredField allFields + when (not $ isNil requiredFields) $ generateConstructor descriptorsByEncloser classExport requiredFields + +generateAllArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateAllArgsConstructor descriptorsByEncloser classExport = do + let Just (MkAnnotation _ props) = findAllArgsConstructor classExport + | _ => Pure () + let fields = getFields $ fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + let excludedFields = getStringAnnotationValues $ snd $ fromMaybe ("exclude", AnnArray []) $ + (find (\(name, value) => name == "exclude") props) + let constructorFields = filter (\fieldExport => not $ elem fieldExport.name excludedFields) fields + generateConstructor descriptorsByEncloser classExport constructorFields + +generateNoArgsConstructor : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateNoArgsConstructor descriptorsByEncloser classExport = do + CreateMethod [Public] "generated.idr" classExport.name "" "()V" Nothing Nothing [] [] + MethodCodeStart + Aload 0 + extendsTypeName <- getJvmReferenceTypeName classExport.extends + InvokeMethod InvokeSpecial extendsTypeName "" "()V" False + Return + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +generateHashCode : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateHashCode descriptorsByEncloser classExport = do + let fields = filter (not . isTransientField) $ getFields $ + fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + CreateMethod [Public] "generated.idr" classExport.name "hashCode" "()I" Nothing Nothing [] [] + MethodCodeStart + let fieldsCount = the Int $ cast $ length fields + Iconst fieldsCount + Anewarray "java/lang/Object" + traverse_ (uncurry loadField) $ zip [0 .. fieldsCount - 1] fields + InvokeMethod InvokeStatic "java/util/Objects" "hash" "([Ljava/lang/Object;)I" False + Ireturn + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + where + loadField : Int -> FieldExport -> Asm () + loadField index field = do + Dup + Iconst index + Aload 0 + let fieldType = field.type + Field GetField classExport.name field.name (getJvmTypeDescriptor fieldType) + asmCast fieldType inferredObjectType + Aastore + +generateEquals : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateEquals descriptorsByEncloser classExport = do + let fields = filter (not . isTransientField) $ getFields $ + fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + CreateMethod [Public] "generated.idr" classExport.name "equals" "(Ljava/lang/Object;)Z" Nothing Nothing [] [] + MethodCodeStart + Aload 0 + Aload 1 + refEqLabel <- newLabel + CreateLabel refEqLabel + Ifacmpne refEqLabel + Iconst 1 + Ireturn + LabelStart refEqLabel + Aload 1 + let className = classExport.name + InstanceOf className + instanceOfLabel <- newLabel + CreateLabel instanceOfLabel + Ifne instanceOfLabel + Iconst 0 + Ireturn + LabelStart instanceOfLabel + Aload 1 + checkcast className + Astore 2 + let fieldsCount = the Int $ cast $ length fields + equalsLabel <- newLabel + CreateLabel equalsLabel + equalsFields equalsLabel fields + Iconst 1 + methodEndLabel <- newLabel + CreateLabel methodEndLabel + Goto methodEndLabel + LabelStart equalsLabel + Iconst 0 + LabelStart methodEndLabel + Ireturn + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + where + equalsFields : String -> List FieldExport -> Asm () + equalsFields equalsLabel [] = Pure () + equalsFields equalsLabel (field :: rest) = do + let fieldType = field.type + let className = classExport.name + Aload 0 + Field GetField className field.name (getJvmTypeDescriptor fieldType) + asmCast fieldType inferredObjectType + Aload 2 + Field GetField className field.name (getJvmTypeDescriptor fieldType) + asmCast fieldType inferredObjectType + InvokeMethod InvokeStatic "java/util/Objects" "equals" "(Ljava/lang/Object;Ljava/lang/Object;)Z" False + Ifeq equalsLabel + equalsFields equalsLabel rest + +generateToString : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateToString descriptorsByEncloser classExport = do + let fields = getFields $ fromMaybe [] $ SortedMap.lookup classExport descriptorsByEncloser + CreateMethod [Public] "generated.idr" classExport.name "toString" "()Ljava/lang/String;" Nothing Nothing [] [] + MethodCodeStart + New "java/lang/StringBuilder" + Dup + InvokeMethod InvokeSpecial "java/lang/StringBuilder" "" "()V" False + Ldc $ StringConst classExport.name + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "append" "(Ljava/lang/String;)Ljava/lang/StringBuilder;" False + let hasFields = not $ isNil fields + when hasFields $ do + appendFields "{" fields + Iconst 125 -- '}' + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "append" "(C)Ljava/lang/StringBuilder;" False + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "toString" "()Ljava/lang/String;" False + Areturn + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + where + getAppendParamType : InferredType -> InferredType + getAppendParamType IChar = IChar + getAppendParamType IBool = IBool + getAppendParamType (IArray IChar) = IArray IChar + getAppendParamType IDouble = IDouble + getAppendParamType IFloat = IFloat + getAppendParamType IInt = IInt + getAppendParamType IByte = IInt + getAppendParamType IShort = IInt + getAppendParamType ILong = ILong + getAppendParamType ty = + if (ty == iref "java/lang/CharSequence" [] || ty == inferredStringType || + ty == iref "java/lang/StringBuffer" []) then ty + else inferredObjectType + + appendFields : String -> List FieldExport -> Asm () + appendFields _ [] = Pure () + appendFields prefixChar (field :: rest) = do + let fieldName = field.name + let fieldType = field.type + let className = classExport.name + let isStringField = field.type == inferredStringType + Ldc $ StringConst (prefixChar ++ fieldName ++ "=" ++ if isStringField then "'" else "") + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "append" "(Ljava/lang/String;)Ljava/lang/StringBuilder;" False + Aload 0 + Field GetField className fieldName (getJvmTypeDescriptor fieldType) + let appendParamType = getAppendParamType fieldType + asmCast fieldType appendParamType + let stringBuilderType = iref "java/lang/StringBuilder" [] + let appendDescriptor = getMethodDescriptor $ MkInferredFunctionType stringBuilderType [appendParamType] + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "append" appendDescriptor False + when isStringField $ do + Iconst 39 -- single quote + InvokeMethod InvokeVirtual "java/lang/StringBuilder" "append" "(C)Ljava/lang/StringBuilder;" False + appendFields ", " rest + +generateDataClass : SortedMap ClassExport (List ExportDescriptor) -> ClassExport -> Asm () +generateDataClass descriptorsByEncloser classExport = do + generateGetters descriptorsByEncloser classExport + generateSetters descriptorsByEncloser classExport + generateRequiredArgsConstructor descriptorsByEncloser classExport + generateHashCode descriptorsByEncloser classExport + generateEquals descriptorsByEncloser classExport + generateToString descriptorsByEncloser classExport + +exportMemberIo : AsmGlobalState -> SortedMap ClassExport (List ExportDescriptor) -> ExportDescriptor -> IO () +exportMemberIo globalState descriptorsByEncloser (MkMethodExportDescriptor desc) = + if desc.name == "" + then do + let idrisName = desc.idrisName + fcDef <- getFcAndDefinition globalState (jvmSimpleName idrisName) + case nullableToMaybe fcDef of + Just (fc, MkNmFun args expr) => do + let jname = jvmName desc.idrisName + let dottedClassName = replace (className jname) '/' '.' + let constructorIdrisName = NS (mkNamespace desc.encloser.name) (UN $ Basic (methodName jname ++ "")) + programName <- AsmGlobalState.getProgramName globalState + asmState <- createAsmStateJavaName globalState desc.encloser.name + ignore $ asm asmState $ do + Just superCallExpr <- getSuperCallExpr expr + | Nothing => asmCrash ("Constructor export for " ++ show idrisName ++ " should call 'super'") + inferDef programName constructorIdrisName fc (MkNmFun args superCallExpr) + resetScope + loadFunction $ jvmName constructorIdrisName + exportFunction desc + scopes <- LiftIo $ ArrayList.new {elemTy=Scope} + updateCurrentFunction $ { scopes := (subtyping scopes), optimizedBody := emptyFunction } + _ => pure () + else do + asmState <- createAsmStateJavaName globalState desc.encloser.name + ignore $ asm asmState $ exportFunction desc +exportMemberIo globalState descriptorsByEncloser (MkFieldExportDescriptor desc) = do + asmState <- createAsmStateJavaName globalState desc.encloser.name + ignore $ asm asmState $ exportField desc +exportMemberIo globalState descriptorsByEncloser (MkClassExportDescriptor classExport) = do + asmState <- createAsmStateJavaName globalState classExport.name + ignore $ asm asmState $ exportClass classExport + let hasDataAnnotation = isJust (findClassAnnotation "Data" classExport) + ignore $ asm asmState $ generateAllArgsConstructor descriptorsByEncloser classExport + when (isJust (findNoArgsConstructor classExport)) $ + ignore $ asm asmState $ generateNoArgsConstructor descriptorsByEncloser classExport + when (not hasDataAnnotation && isJust (findRequiredArgsConstructor classExport)) $ + ignore $ asm asmState $ generateRequiredArgsConstructor descriptorsByEncloser classExport + when hasDataAnnotation $ ignore $ asm asmState $ generateDataClass descriptorsByEncloser classExport + when (not hasDataAnnotation && isJust (findClassAnnotation "Getter" classExport)) $ + ignore $ asm asmState $ generateGetters descriptorsByEncloser classExport + when (not hasDataAnnotation && isJust (findClassAnnotation "Setter" classExport)) $ + ignore $ asm asmState $ generateSetters descriptorsByEncloser classExport + when (not hasDataAnnotation && isJust (findClassAnnotation "EqualsAndHashCode" classExport)) $ do + ignore $ asm asmState $ generateEquals descriptorsByEncloser classExport + ignore $ asm asmState $ generateHashCode descriptorsByEncloser classExport +exportMemberIo _ _ _ = pure () + +groupByEncloser : List ExportDescriptor -> SortedMap ClassExport (List ExportDescriptor) +groupByEncloser descriptors = + let (classExports, methodFieldExports) = partitionExports ([], []) descriptors + classExportsByName = SortedMap.fromList $ (\classExport => (classExport.name, classExport)) <$> classExports + in pairEncloserDescriptor classExportsByName empty methodFieldExports + where + partitionExports : (List ClassExport, List ExportDescriptor) -> List ExportDescriptor -> + (List ClassExport, List ExportDescriptor) + partitionExports acc [] = acc + partitionExports (classExports, methodFieldExports) (desc@(MkMethodExportDescriptor _) :: rest) = + partitionExports (classExports, desc :: methodFieldExports) rest + partitionExports (classExports, methodFieldExports) (desc@(MkFieldExportDescriptor _) :: rest) = + partitionExports (classExports, desc :: methodFieldExports) rest + partitionExports (classExports, methodFieldExports) (desc@(MkImportDescriptor _ _) :: rest) = + partitionExports (classExports, methodFieldExports) rest + partitionExports (classExports, methodFieldExports) ((MkClassExportDescriptor desc) :: rest) = + partitionExports (desc :: classExports, methodFieldExports) rest + + updateExportDescriptors : ClassExport -> ExportDescriptor -> SortedMap ClassExport (List ExportDescriptor) -> + SortedMap ClassExport (List ExportDescriptor) + updateExportDescriptors classExport desc descriptorsByEncloser = + mergeWith (++) descriptorsByEncloser (singleton classExport [desc]) + + pairEncloserDescriptor : SortedMap String ClassExport -> SortedMap ClassExport (List ExportDescriptor) -> + List ExportDescriptor -> SortedMap ClassExport (List ExportDescriptor) + pairEncloserDescriptor classExports acc [] = acc + pairEncloserDescriptor classExports acc (desc@(MkMethodExportDescriptor methodExport) :: rest) = + let encloser = methodExport.encloser + classExport = fromMaybe encloser (SortedMap.lookup encloser.name classExports) + in pairEncloserDescriptor classExports (updateExportDescriptors classExport desc acc) rest + pairEncloserDescriptor classExports acc (desc@(MkFieldExportDescriptor fieldExport) :: rest) = + let encloser = fieldExport.encloser + classExport = fromMaybe encloser (SortedMap.lookup encloser.name classExports) + in pairEncloserDescriptor classExports (updateExportDescriptors classExport desc acc) rest + pairEncloserDescriptor classExports acc (_ :: rest) = pairEncloserDescriptor classExports acc rest + +export +exportDefs : AsmGlobalState -> List (Name, String) -> IO () +exportDefs globalState nameAndDescriptors = do + descriptors <- parseExportDescriptors globalState nameAndDescriptors + let descriptorsByEncloser = groupByEncloser descriptors + traverse_ (exportMemberIo globalState descriptorsByEncloser) descriptors + +export +getExport : NoMangleMap -> Name -> Maybe (Name, String) +getExport noMangleMap name = (\descriptor => (name, descriptor)) <$> isNoMangle noMangleMap name + ||| Compile a TT expression to JVM bytecode compileToJvmBytecode : Ref Ctxt Defs -> String -> String -> ClosedTerm -> Core () compileToJvmBytecode c outputDirectory outputFile term = do - cdata <- getCompileData False Cases term + noMangleMapRef <- initNoMangle ["jvm"] (const True) + noMangleMap <- get NoMangleMap + cdata <- getCompileDataWith ["jvm"] False Cases term directives <- getDirectives Jvm let ndefs = namedDefs cdata let idrisMainBody = forget (mainExpr cdata) @@ -1871,14 +2486,15 @@ compileToJvmBytecode c outputDirectory outputFile term = do fcAndDefinitionsByName <- coreLift $ Map.fromList nameStrFcDefs let nameStrDefs = getNameStrDef <$> nameStrFcDefs definitionsByName <- coreLift $ Map.fromList nameStrDefs - globalState <- coreLift $ newAsmGlobalState programName - let names = groupByClassName programName . traverseDepthFirst $ - buildFunctionTreeMain mainFunctionName definitionsByName + globalState <- coreLift $ newAsmGlobalState programName fcAndDefinitionsByName + let names = fst <$> nameFcDefs + let namesByClassName = groupByClassName programName names coreLift $ do - assembleAsync globalState fcAndDefinitionsByName (transpose names) - asmState <- createAsmState globalState mainFunctionName + assembleAsync globalState fcAndDefinitionsByName (transpose namesByClassName) + exportDefs globalState $ mapMaybe (getExport noMangleMap) (fst <$> allDefs) + mainAsmState <- createAsmState globalState mainFunctionName let mainFunctionJname = jvmName mainFunctionName - _ <- runAsm asmState $ createMainMethod programName mainFunctionJname + _ <- runAsm mainAsmState $ createMainMethod programName mainFunctionJname classCodeEnd globalState outputDirectory outputFile (className mainFunctionJname) ||| JVM bytecode implementation of the `compileExpr` interface. diff --git a/src/Compiler/Jvm/Export.idr b/src/Compiler/Jvm/Export.idr new file mode 100644 index 000000000..cfdb1dba7 --- /dev/null +++ b/src/Compiler/Jvm/Export.idr @@ -0,0 +1,691 @@ +module Compiler.Jvm.Export + +import Compiler.Common +import Compiler.CompileExpr +import Compiler.Inline +import Compiler.NoMangle +import Compiler.Jvm.Asm +import Compiler.Jvm.ExtPrim +import Compiler.Jvm.InferredType +import Compiler.Jvm.Jname +import Compiler.Jvm.Optimizer +import Compiler.Jvm.Variable +import Core.Context +import Core.Directory +import Core.Name +import Core.Name.Namespace +import Core.Options +import Core.TT +import Data.List +import Data.List1 +import Data.Maybe +import Data.String +import Data.Vect +import Debug.Trace +import Language.JSON +import Libraries.Data.SortedMap +import Libraries.Utils.Path + +import System.FFI + +mutual + parseAnnotationTypeValue : Name -> String -> String -> JSON -> Asm AnnotationValue + parseAnnotationTypeValue functionName annotationName "int" (JNumber value) = Pure $ AnnInt $ cast value + parseAnnotationTypeValue functionName annotationName "boolean" (JBoolean value) = Pure $ AnnBoolean value + parseAnnotationTypeValue functionName annotationName "char" (JString value) = + Pure $ AnnChar $ assert_total (prim__strHead value) + parseAnnotationTypeValue functionName annotationName "double" (JNumber value) = Pure $ AnnDouble value + parseAnnotationTypeValue functionName annotationName "String" (JString value) = Pure $ AnnString value + parseAnnotationTypeValue functionName annotationName "class" (JString value) = Pure $ AnnClass value + parseAnnotationTypeValue functionName annotationName "enum" (JObject properties) = do + let propertiesByName = SortedMap.fromList properties + let Just (JString type) = lookup "type" properties + | _ => asmCrash ("Expected 'string' enum type for annotation " ++ show annotationName ++ " in " ++ + show functionName) + let Just (JString value) = lookup "value" properties + | _ => asmCrash ("Expected 'string' enum value for annotation " ++ show annotationName ++ " in " ++ + show functionName) + Pure $ AnnEnum type value + parseAnnotationTypeValue functionName annotationName "annotation" annotationJson = do + annotation <- parseAnnotation functionName annotationJson + Pure $ AnnAnnotation annotation + parseAnnotationTypeValue functionName annotationName type _ = + asmCrash ("Unknown type " ++ show type ++ " for annotation " ++ annotationName ++ " in " ++ show functionName) + + parseAnnotationValue : Name -> String -> JSON -> Asm AnnotationValue + parseAnnotationValue functionName annotationName (JNumber value) = Pure $ AnnInt $ cast value + parseAnnotationValue functionName annotationName (JString value) = Pure $ AnnString value + parseAnnotationValue functionName annotationName (JBoolean value) = Pure $ AnnBoolean value + parseAnnotationValue functionName annotationName (JObject properties) = do + let propertiesByName = SortedMap.fromList properties + let Just (JString type) = lookup "type" propertiesByName + | _ => asmCrash ("Missing 'string' type for annotation " ++ annotationName ++ " in " ++ show functionName) + let Just value = SortedMap.lookup "value" propertiesByName + | _ => asmCrash ("Missing 'string' value for annotation " ++ annotationName ++ " in " ++ show functionName) + parseAnnotationTypeValue functionName annotationName type value + parseAnnotationValue functionName annotationName (JArray valuesJson) = + Pure $ AnnArray !(traverse (parseAnnotationValue functionName annotationName) valuesJson) + parseAnnotationValue functionName annotationName JNull = asmCrash ("Annotation property value cannot be null " ++ + " for annotation " ++ show annotationName ++ " in function " ++ show functionName) + + parseAnnotationProperty : Name -> String -> String -> JSON -> Asm AnnotationProperty + parseAnnotationProperty functionName annotationName propertyName valueJson = do + value <- parseAnnotationValue functionName annotationName valueJson + Pure $ (propertyName, value) + + parseAnnotation : Name -> JSON -> Asm Annotation + parseAnnotation functionName (JObject [(annotationName, (JObject propertyNameAndValues))]) = do + properties <- traverse + (\(propertyName, value) => parseAnnotationProperty functionName annotationName propertyName value) + propertyNameAndValues + Pure $ MkAnnotation annotationName properties + parseAnnotation functionName (JObject [(annotationName, simplifiedValue)]) = + parseAnnotation functionName (JObject [(annotationName, (JObject [("value", simplifiedValue)]))]) + parseAnnotation functionName _ = + asmCrash ("Expected a JSON object for parameter annotations in " ++ show functionName) + +parseAnnotations : Name -> JSON -> Asm (List Annotation) +parseAnnotations functionName (JArray annotations) = traverse (parseAnnotation functionName) annotations +parseAnnotations functionName _ = asmCrash ("Expected an array for parameter annotations in " ++ show functionName) + +record ExportArgument where + constructor MkExportArgument + type: InferredType + annotations: List Annotation + +parseArgument : Name -> List (String, JSON) -> Asm ExportArgument +parseArgument functionName keyAndValues = do + let valuesByKey = SortedMap.fromList keyAndValues + let Just (JString typeStr) = lookup "type" valuesByKey + | _ => asmCrash $ "Expected 'string' argument type for " ++ show functionName + let annotationsJson = fromMaybe (JArray []) $ lookup "annotations" valuesByKey + annotations <- parseAnnotations functionName annotationsJson + Pure $ MkExportArgument (parse typeStr) annotations + +parseArgumentsJson : Name -> JSON -> Asm (List ExportArgument) +parseArgumentsJson functionName (JArray arguments) = go arguments where + go : List JSON -> Asm (List ExportArgument) + go [] = Pure [] + go ((JObject keyAndValues) :: rest) = do + argument <- parseArgument functionName keyAndValues + restArguments <- go rest + Pure (argument :: restArguments) + go _ = asmCrash ("Expected an argument object for foreign export function: " ++ show functionName) +parseArgumentsJson functionName _ = + asmCrash ("Expected an array of arguments for foreign export function: " ++ show functionName) + +export +loadArguments : Map Int InferredType -> Name -> Int -> List InferredType -> Asm () +loadArguments typesByIndex functionName arity idrisTypes = go 0 idrisTypes + where + go : Int -> List InferredType -> Asm () + go n [] = + if n == arity + then Pure () + else asmCrash ("JVM and Idris types do not match in foreign export for " ++ show functionName) + go varIndex (idrisType :: rest) = do + Just jvmType <- nullableToMaybe <$> Map.get typesByIndex varIndex + | Nothing => do -- World type only exists for Idris functions + Iconst 0 -- Load "world" for PrimIO functions + InvokeMethod InvokeStatic "java/lang/Integer" "valueOf" "(I)Ljava/lang/Integer;" False + loadVar typesByIndex jvmType idrisType varIndex + go (varIndex + 1) rest + +public export +record ClassExport where + constructor MkClassExport + name: String + idrisName: Name + extends: InferredType + implements: List InferredType + modifiers: List Access + annotations: List Annotation + +public export +Eq ClassExport where + export1 == export2 = export1.name == export2.name + +public export +Ord ClassExport where + compare = comparing name + +public export +record MethodExport where + constructor MkMethodExport + name: String + idrisName: Name + type: InferredFunctionType + shouldPerformIO: Bool + encloser: ClassExport + modifiers: List Access + annotations: List Annotation + parameterAnnotations: List (List Annotation) + +public export +record FieldExport where + constructor MkFieldExport + name: String + type: InferredType + encloser: ClassExport + modifiers: List Access + annotations: List Annotation + +public export +data ExportDescriptor : Type where + MkFieldExportDescriptor : FieldExport -> ExportDescriptor + MkMethodExportDescriptor : MethodExport -> ExportDescriptor + MkClassExportDescriptor : ClassExport -> ExportDescriptor + MkImportDescriptor : Name -> SortedMap String String -> ExportDescriptor + +parseModifier : Name -> String -> Access +parseModifier _ "public" = Public +parseModifier _ "private" = Private +parseModifier _ "static" = Static +parseModifier _ "synthetic" = Synthetic +parseModifier _ "final" = Final +parseModifier _ "interface" = Interface +parseModifier _ "abstract" = Abstract +parseModifier _ "transient" = Transient +parseModifier name invalid = believe_me $ crash ("Invalid modifier " ++ invalid ++ " in export " ++ show name) + +parseString : String -> JSON -> Asm String +parseString _ (JString value) = Pure value +parseString errorMessage _ = asmCrash errorMessage + +getEncloser : ExportDescriptor -> Maybe ClassExport +getEncloser (MkMethodExportDescriptor methodExport) = Just methodExport.encloser +getEncloser (MkFieldExportDescriptor fieldExport) = Just fieldExport.encloser +getEncloser (MkClassExportDescriptor classExport) = Just classExport +getEncloser (MkImportDescriptor _ _) = Nothing + +parseModifierJson : Name -> JSON -> Access +parseModifierJson name (JString value) = parseModifier name value +parseModifierJson name invalid = believe_me $ crash ("Invalid modifier " ++ show invalid ++ " in export " ++ show name) + +parseModifiers : Name -> JSON -> List Access +parseModifiers name (JArray modifiers) = (parseModifierJson name) <$> modifiers +parseModifiers name invalid = believe_me $ crash ("Invalid modifiers " ++ show invalid ++ " in export " ++ show name) + +parseClassFieldExport : Name -> ClassExport -> String -> JSON -> Asm FieldExport +parseClassFieldExport idrisName encloser fieldName (JString type) = + Pure $ MkFieldExport fieldName (parse type) encloser [Private] [] +parseClassFieldExport idrisName encloser fieldName (JObject desc) = do + let modifiersJson = fromMaybe (JArray [JString "private"]) $ lookup "modifiers" desc + let modifiers = parseModifiers idrisName modifiersJson + let Just typeJson = lookup "type" desc + | _ => asmCrash ("Missing type for " ++ fieldName ++ " in export " ++ show idrisName) + type <- parseString ("Invalid type for " ++ fieldName ++ " in export " ++ show idrisName) typeJson + let annotationsJson = fromMaybe (JArray []) $ lookup "annotations" desc + annotations <- parseAnnotations idrisName annotationsJson + Pure $ MkFieldExport fieldName (parse type) encloser modifiers annotations +parseClassFieldExport idrisName encloser fieldName descriptor = + asmCrash ("Expected a JSON string or object for field export in " ++ show idrisName ++ + " but found: " ++ show descriptor) + +parseClassFieldExports : Name -> ClassExport -> SortedMap String JSON -> Asm (List FieldExport) +parseClassFieldExports name encloser descriptor = case lookup "fields" descriptor of + Nothing => Pure [] + Just (JObject nameAndValues) => traverse (uncurry $ parseClassFieldExport name encloser) nameAndValues + Just descriptor => asmCrash ("Expected a JSON object for exported fields in " ++ show name ++ + " but found: " ++ show descriptor) + +getModifiersAndName : Name -> List Access -> List String -> (List Access, String) +getModifiersAndName name acc [] = believe_me $ crash ("Missing exported function name in " ++ show name) +getModifiersAndName _ acc (functionName :: []) = (acc, functionName) +getModifiersAndName name acc (modifier :: rest) = getModifiersAndName name (parseModifier name modifier :: acc) rest + +parseClassExport : Name -> (parts : List String) -> SortedMap String JSON -> List Annotation -> + Asm (List ExportDescriptor) +parseClassExport name parts descriptor annotations = do + let isInterface = "interface" `elem` parts + extends <- if isInterface + then Pure "java/lang/Object" + else case lookup "extends" descriptor of + Nothing => Pure "java/lang/Object" + Just (JString superName) => Pure superName + _ => asmCrash ("Invalid 'extends' for " ++ show name) + let implementsKey = if isInterface then "extends" else "implements" + implements <- case lookup implementsKey descriptor of + Nothing => Pure [] + Just (JArray implementsJson) => + traverse (parseString ("Expected a string value for '" ++ implementsKey ++ "' for " ++ show name)) + implementsJson + _ => asmCrash ("Invalid '" ++ implementsKey ++ "' for " ++ show name ++ + ". Expected an array of type names.") + let (modifiers, jvmFunctionName) = getModifiersAndName name [] parts + let classExport = MkClassExport jvmFunctionName name (parse extends) (parse <$> implements) + modifiers annotations + let classExportDescriptor = MkClassExportDescriptor classExport + fieldExportDescriptors <- parseClassFieldExports name classExport descriptor + Pure $ (classExportDescriptor :: (MkFieldExportDescriptor <$> fieldExportDescriptors)) + +getReferenceTypeName : String -> InferredType -> Asm String +getReferenceTypeName _ (IRef name _ _) = Pure name +getReferenceTypeName functionName _ = asmCrash ("Expected a reference type to export function " ++ functionName) + +makePublicByDefault : List Access -> List Access +makePublicByDefault modifiers = + let accessModifiers = the (List Access) [Public, Private, Protected] + in if any (flip elem accessModifiers) modifiers + then modifiers + else (Public :: modifiers) + +parseJvmReturnType : String -> SortedMap String JSON -> Asm InferredType +parseJvmReturnType functionName descriptor = do + typeString <- parseString ("Invalid return type for function " ++ functionName) $ + fromMaybe (JString "java/lang/Object") $ lookup "returnType" descriptor + Pure $ parse typeString + +stripLastChar : String -> String +stripLastChar str = case length str of + Z => str + (S n) => substr 0 n str + +parseMethodExport : Name -> (javaName: String) -> (nameParts: List String) -> + SortedMap String JSON -> List Annotation -> Asm MethodExport +parseMethodExport idrisName javaName parts descriptor annotations = do + let argumentsJson = fromMaybe (JArray []) $ lookup "arguments" descriptor + arguments <- parseArgumentsJson idrisName argumentsJson + let (jvmArgumentTypes, parameterAnnotations) = + unzip $ (\(MkExportArgument type annotations) => (type, annotations)) <$> arguments + let (modifiers, initialMethodName) = getModifiersAndName idrisName [] parts + let shouldPerformIO = endsWith initialMethodName "!" + let methodName = if shouldPerformIO then stripLastChar initialMethodName else initialMethodName + jvmReturnType <- if methodName == "" then Pure IVoid else parseJvmReturnType javaName descriptor + let functionType = MkInferredFunctionType jvmReturnType jvmArgumentTypes + let adjustedModifiers = makePublicByDefault modifiers + let isInstance = not $ elem Static modifiers + let adjustedParameterAnnotations = if isInstance then drop 1 parameterAnnotations else parameterAnnotations + enclosingTypeName <- if isInstance + then case jvmArgumentTypes of + [] => asmCrash ("Expected first argument to be a reference type for instance member in " ++ javaName) + (enclosingType :: _) => getReferenceTypeName javaName enclosingType + else case lookup "enclosingType" descriptor of + Nothing => asmCrash ("Missing 'enclosingType' for " ++ javaName) + Just enclosingTypeJson => parseString ("Invalid enclosing type for function " ++ javaName) enclosingTypeJson + [MkClassExportDescriptor encloser] <- case words enclosingTypeName of + [] => asmCrash ("Unable to determine enclosing type for " ++ javaName) + enclosingTypeParts@(_ :: _) => + parseClassExport idrisName enclosingTypeParts SortedMap.empty [] + | _ => asmCrash ("Unexpected 'enclosingType' for " ++ show javaName) + Pure $ MkMethodExport methodName idrisName functionType shouldPerformIO encloser adjustedModifiers annotations + adjustedParameterAnnotations + +parseFieldExport : Name -> (nameParts: List String) -> + SortedMap String JSON -> List Annotation -> Asm (List ExportDescriptor) +parseFieldExport name parts descriptor annotations = do + let (modifiers, fieldName) = getModifiersAndName name [] parts + Just enclosingTypeName <- + traverse (parseString ("Invalid 'enclosingType' for " ++ show name)) $ lookup "enclosingType" descriptor + | Nothing => asmCrash ("Missing 'enclosingType' for " ++ show name) + [MkClassExportDescriptor encloser] <- case words enclosingTypeName of + [] => asmCrash ("Missing enclosing type for " ++ show name) + enclosingTypeParts@(_ :: _) => parseClassExport name enclosingTypeParts SortedMap.empty [] + | _ => asmCrash ("Unexpected 'enclosingType' for " ++ show name) + Just typeString <- traverse (parseString ("Invalid type for field " ++ show name)) $ lookup "type" descriptor + | Nothing => asmCrash ("Missing type for " ++ show name) + let type = parse typeString + Pure [MkFieldExportDescriptor $ MkFieldExport fieldName type encloser modifiers annotations] + +parseObjectExportDescriptor : Name -> String -> List (String, JSON) -> Asm (List ExportDescriptor) +parseObjectExportDescriptor idrisName javaName descriptorKeyAndValues = do + let descriptor = SortedMap.fromList descriptorKeyAndValues + let annotationsJson = fromMaybe (JArray []) $ lookup "annotations" descriptor + annotations <- parseAnnotations idrisName annotationsJson + case words javaName of + [] => asmCrash ("Invalid export descriptor " ++ javaName) + parts@(_ :: _) => + cond + [ + ((isJust (lookup "returnType" descriptor) || elem "" parts), + do + methodExport <- parseMethodExport idrisName javaName parts descriptor annotations + Pure [MkMethodExportDescriptor methodExport]), + (isJust $ lookup "type" descriptor, parseFieldExport idrisName parts descriptor annotations) + ] + (parseClassExport idrisName parts descriptor annotations) + +parseJsonExport : Name -> String -> Asm (List ExportDescriptor) +parseJsonExport functionName descriptor = case String.break (\c => c == '{') descriptor of + ("", _) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_, "") => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (name, signature) => do + case JSON.parse signature of + Just (JObject keyAndValues) => parseObjectExportDescriptor functionName name keyAndValues + _ => asmCrash ("Invalid foreign export descriptor " ++ descriptor ++ " for " ++ show functionName) + +parseMethodSimpleExport : Name -> String -> Asm MethodExport +parseMethodSimpleExport functionName descriptor = case String.break (\c => c == '.') descriptor of + ("", instanceMethodNameAndSig) => case words instanceMethodNameAndSig of + [] => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: _ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (javaName :: instanceTypeString :: types@(_ :: _)) => do + let shouldPerformIO = endsWith javaName "!" + let javaName = if shouldPerformIO then stripLastChar javaName else javaName + let instanceType = parse instanceTypeString + let functionType = MkInferredFunctionType (parse (last types)) (instanceType :: (parse <$> (init types))) + className <- getReferenceTypeName ("Invalid instance type in export for " ++ show functionName) instanceType + let encloser = MkClassExport className functionName inferredObjectType [] [Public] [] + Pure $ MkMethodExport javaName functionName functionType shouldPerformIO encloser [Public] [] [] + (className, staticMethodNameAndArgs) => case words staticMethodNameAndArgs of + [] => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (javaName :: types@(_ :: _)) => do + let shouldPerformIO = endsWith javaName "!" + let javaName = if shouldPerformIO then stripLastChar javaName else javaName + let functionType = MkInferredFunctionType (parse (last types)) (parse <$> (init types)) + let encloser = MkClassExport className functionName inferredObjectType [] [Public] [] + Pure $ MkMethodExport javaName functionName functionType shouldPerformIO encloser [Public, Static] [] [] + +parseFieldSimpleExport : Name -> String -> Asm FieldExport +parseFieldSimpleExport functionName descriptor = case String.break (\c => c == '#') descriptor of + ("", instanceFieldNameAndSig) => case words instanceFieldNameAndSig of + [] => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: _ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (javaName :: instanceType :: type :: _) => do + className <- getReferenceTypeName ("Invalid instance type in export for " ++ show functionName) + (parse instanceType) + let encloser = MkClassExport className functionName inferredObjectType [] [Public] [] + Pure $ MkFieldExport javaName (parse type) encloser [Public] [] + (className, staticFieldNameAndType) => case words staticFieldNameAndType of + [] => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_ :: []) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (javaName :: type :: _) => do + let encloser = MkClassExport className functionName inferredObjectType [] [Public] [] + Pure $ MkFieldExport javaName (parse type) encloser [Public, Static] [] + +%foreign jvm' "java/lang/Character" "isWhitespace" "char" "boolean" +isWhitespace : Char -> Bool + +parseImport : String -> Maybe (String, String) +parseImport line = case words line of + (type :: []) => + let alias = (Prelude.reverse . fst . break (== '/') . Prelude.reverse) type + in Just (alias, type) + (type :: alias :: []) => Just (alias, type) + _ => Nothing + +getNamespace : Name -> Namespace +getNamespace (NS n _) = n +getNamespace n = emptyNS + +parseImports : Name -> String -> Asm ExportDescriptor +parseImports functionName descriptor = + case String.break isWhitespace descriptor of + ("", _) => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_, "") => asmCrash ("Invalid foreign export descriptor for " ++ show functionName) + (_, importsDescriptor) => + Pure $ MkImportDescriptor functionName $ SortedMap.fromList $ catMaybes $ parseImport <$> lines importsDescriptor + +parseExportDescriptor : Name -> String -> Asm (List ExportDescriptor) +parseExportDescriptor functionName descriptor = cond + [ + ("{" `isInfixOf` descriptor, parseJsonExport functionName descriptor), + ("." `isInfixOf` descriptor, do + methodExport <- parseMethodSimpleExport functionName descriptor + Pure [MkMethodExportDescriptor methodExport]), + ("#" `isInfixOf` descriptor, do + fieldExport <- parseFieldSimpleExport functionName descriptor + Pure $ [MkFieldExportDescriptor fieldExport]) + ] + (Pure [!(parseImports functionName descriptor)]) + +export +adjustArgumentsForInstanceMember : Name -> (isInstance: Bool) -> List InferredType -> Asm (List InferredType) +adjustArgumentsForInstanceMember _ False argumentTypes = Pure argumentTypes +adjustArgumentsForInstanceMember _ _ (_ :: jvmArgumentTypes) = Pure jvmArgumentTypes +adjustArgumentsForInstanceMember idrisName _ _ = + asmCrash ("Expected first argument to be a reference type for instance member in " ++ show idrisName) + +export +createAccessorName : String -> String -> Asm String +createAccessorName pfix fieldName = case strM fieldName of + StrNil => asmCrash "Field name cannot be empty" + StrCons firstLetter rest => Pure (pfix ++ strCons (toUpper firstLetter) rest) + +export +createGetter : ClassExport -> FieldExport -> Asm () +createGetter classExport fieldExport = do + let fieldName = fieldExport.name + getterName <- createAccessorName "get" fieldName + let fieldType = fieldExport.type + let getterType = getMethodDescriptor $ MkInferredFunctionType fieldType [] + let isStatic = elem Static fieldExport.modifiers + let getterModifiers = Public :: (if isStatic then [Static] else []) + let className = classExport.name + CreateMethod getterModifiers "generated.idr" className getterName getterType Nothing Nothing [] [] + MethodCodeStart + when (not isStatic) $ Aload 0 + let instructionType = if isStatic then GetStatic else GetField + Field instructionType className fieldName (getJvmTypeDescriptor fieldType) + asmReturn fieldType + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +export +createSetter : ClassExport -> FieldExport -> Asm () +createSetter classExport fieldExport = do + let fieldName = fieldExport.name + setterName <- createAccessorName "set" fieldName + let fieldType = fieldExport.type + let isStatic = elem Static fieldExport.modifiers + let setterType = MkInferredFunctionType IVoid [fieldType] + let descriptor = getMethodDescriptor setterType + let signature = Just $ getMethodSignature setterType + let setterModifiers = Public :: (if isStatic then [Static] else []) + let className = classExport.name + CreateMethod setterModifiers "generated.idr" className setterName descriptor signature Nothing [] [] + MethodCodeStart + CreateLabel methodStartLabel + CreateLabel methodEndLabel + LabelStart methodStartLabel + when (not isStatic) $ Aload 0 + let arity = the Int $ if isStatic then 1 else 2 + let parameterTypes = if isStatic then [fieldType] else [iref className [], fieldType] + jvmArgumentTypesByIndex <- LiftIo $ Map.fromList $ zip [0 .. arity - 1] parameterTypes + let varIndex = the Int $ if isStatic then 0 else 1 + loadVar jvmArgumentTypesByIndex fieldType fieldType varIndex + let instructionType = if isStatic then PutStatic else PutField + Field instructionType className fieldName (getJvmTypeDescriptor fieldType) + Return + LabelStart methodEndLabel + let classDescriptor = getJvmTypeDescriptor $ iref classExport.name [] + LocalVariable "this" classDescriptor Nothing methodStartLabel methodEndLabel 0 + let signature = Just $ getSignature fieldType + LocalVariable fieldName (getJvmTypeDescriptor fieldType) signature methodStartLabel methodEndLabel 1 + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +mutual + getSuperCallExprList : List NamedCExp -> Asm (Maybe NamedCExp) + getSuperCallExprList [] = Pure Nothing + getSuperCallExprList (expr :: rest) = Pure (!(getSuperCallExpr expr) <|> !(getSuperCallExprList rest)) + + getSuperCallExprVect : Vect n NamedCExp -> Asm (Maybe NamedCExp) + getSuperCallExprVect [] = Pure Nothing + getSuperCallExprVect (expr :: rest) = Pure (!(getSuperCallExpr expr) <|> !(getSuperCallExprVect rest)) + + export + getSuperCallExpr : NamedCExp -> Asm (Maybe NamedCExp) + getSuperCallExpr expr@(NmExtPrim _ (NS _ n) args) = if isSuper n then Pure (Just expr) else getSuperCallExprList args + getSuperCallExpr (NmLam _ _ expr) = getSuperCallExpr expr + getSuperCallExpr (NmLet _ _ value expr) = Pure (!(getSuperCallExpr value) <|> !(getSuperCallExpr expr)) + getSuperCallExpr (NmApp _ (NmRef _ name) args) = do + (_, MkNmFun _ def) <- getFcAndDefinition (jvmSimpleName name) + | _ => getSuperCallExprList args + Pure (!(getSuperCallExpr def) <|> !(getSuperCallExprList args)) + getSuperCallExpr (NmOp _ _ args) = getSuperCallExprVect args + getSuperCallExpr (NmForce _ _ expr) = getSuperCallExpr expr + getSuperCallExpr (NmDelay _ _ expr) = getSuperCallExpr expr + getSuperCallExpr (NmConCase _ expr alts deflt) = + getSuperCallCaseExpr (expr :: (getSuperCallConAltExpr <$> alts)) deflt + getSuperCallExpr (NmConstCase _ expr alts deflt) = + getSuperCallCaseExpr (expr :: (getSuperCallConstAltExpr <$> alts)) deflt + getSuperCallExpr _ = Pure Nothing + + getSuperCallConAltExpr : NamedConAlt -> NamedCExp + getSuperCallConAltExpr (MkNConAlt _ _ _ _ expr) = expr + + getSuperCallConstAltExpr : NamedConstAlt -> NamedCExp + getSuperCallConstAltExpr (MkNConstAlt _ expr) = expr + + getSuperCallCaseExpr : List NamedCExp -> Maybe NamedCExp -> Asm (Maybe NamedCExp) + getSuperCallCaseExpr alts Nothing = getSuperCallExprList alts + getSuperCallCaseExpr alts (Just deflt) = Pure (!(getSuperCallExprList alts) <|> !(getSuperCallExpr deflt)) + +substituteTypeName : SortedMap String String -> String -> String +substituteTypeName imports type = fromMaybe type $ SortedMap.lookup type imports + +substituteType : SortedMap String String -> InferredType -> InferredType +substituteType imports ref@(IRef type refType typeParams) = + let substitutedType = substituteTypeName imports type + substitutedTypeParams = substituteType imports <$> typeParams + in IRef substitutedType refType substitutedTypeParams +substituteType imports ref@(IArray (IRef type refType typeParams)) = + maybe ref (\type => IArray $ IRef type refType typeParams) $ SortedMap.lookup type imports +substituteType imports ref@(IArray (IArray type)) = IArray (IArray $ substituteType imports type) +substituteType imports type = type + +substituteFunctionType : SortedMap String String -> InferredFunctionType -> InferredFunctionType +substituteFunctionType imports (MkInferredFunctionType returnType argumentTypes) = + let updatedReturnType = substituteType imports returnType + updatedArgumentTypes = (substituteType imports) <$> argumentTypes + in MkInferredFunctionType updatedReturnType updatedArgumentTypes + +mutual + substituteAnnotationValue : SortedMap String String -> AnnotationValue -> AnnotationValue + substituteAnnotationValue imports (AnnAnnotation annotation) = AnnAnnotation (substituteAnnotation imports annotation) + substituteAnnotationValue imports (AnnArray values) = AnnArray (substituteAnnotationValue imports <$> values) + substituteAnnotationValue imports (AnnEnum type value) = AnnEnum (substituteTypeName imports type) value + substituteAnnotationValue imports (AnnClass value) = AnnClass (substituteTypeName imports value) + substituteAnnotationValue _ value = value + + substituteAnnotationProperty : SortedMap String String -> AnnotationProperty -> AnnotationProperty + substituteAnnotationProperty imports (name, value) = (name, substituteAnnotationValue imports value) + + substituteAnnotation : SortedMap String String -> Annotation -> Annotation + substituteAnnotation imports (MkAnnotation name props) = + MkAnnotation (substituteTypeName imports name) (substituteAnnotationProperty imports <$> props) + +findImports : SortedMap Namespace (SortedMap String String) -> Name -> Maybe (SortedMap String String) +findImports functionImports name = go (sortBy comparingNamespaceLength parents) where + + parents : List Namespace + parents = allParents $ getNamespace name + + comparingNamespaceLength : Namespace -> Namespace -> Ordering + comparingNamespaceLength = comparing (negate . cast {to=Int} . String.length . show) + + go : List Namespace -> Maybe (SortedMap String String) + go [] = Nothing + go (ns :: rest) = maybe (go rest) Just $ SortedMap.lookup ns functionImports + +substituteClassExport : SortedMap Namespace (SortedMap String String) -> ClassExport -> ClassExport +substituteClassExport functionImports desc = case findImports functionImports desc.idrisName of + Nothing => desc + Just imports => + let + updatedName = substituteTypeName imports desc.name + updatedExtends = substituteType imports desc.extends + updatedImplements = substituteType imports <$> desc.implements + updatedAnnotations = substituteAnnotation imports <$> desc.annotations + in MkClassExport updatedName desc.idrisName updatedExtends updatedImplements desc.modifiers updatedAnnotations + +substituteImport : SortedMap Namespace (SortedMap String String) -> ExportDescriptor -> ExportDescriptor +substituteImport functionImports exportDesc@(MkMethodExportDescriptor desc) = + case findImports functionImports desc.idrisName of + Nothing => exportDesc + Just imports => + let + updatedType = substituteFunctionType imports desc.type + updatedEncloser = substituteClassExport functionImports desc.encloser + updatedAnnotations = substituteAnnotation imports <$> desc.annotations + updatedParameterAnnotations = (substituteAnnotation imports <$>) <$> desc.parameterAnnotations + in MkMethodExportDescriptor $ MkMethodExport desc.name desc.idrisName updatedType desc.shouldPerformIO + updatedEncloser desc.modifiers updatedAnnotations updatedParameterAnnotations +substituteImport functionImports exportDesc@(MkFieldExportDescriptor desc) = + case findImports functionImports desc.encloser.idrisName of + Nothing => exportDesc + Just imports => + let + updatedType = substituteType imports desc.type + updatedAnnotations = substituteAnnotation imports <$> desc.annotations + updatedEncloser = substituteClassExport functionImports desc.encloser + in MkFieldExportDescriptor $ MkFieldExport desc.name updatedType updatedEncloser desc.modifiers + updatedAnnotations +substituteImport functionImports (MkClassExportDescriptor desc) = + MkClassExportDescriptor $ substituteClassExport functionImports desc +substituteImport _ desc = desc + +substituteImports : SortedMap Namespace (SortedMap String String) -> List ExportDescriptor -> List ExportDescriptor +substituteImports imports descriptors = (substituteImport imports) <$> descriptors + +export +parseExportDescriptors : AsmGlobalState -> List (Name, String) -> IO (List ExportDescriptor) +parseExportDescriptors globalState descriptors = do + (imports, exportDescriptors) <- go (SortedMap.empty, []) descriptors + pure $ substituteImports imports $ sortBy (comparing memberTypeOrder) exportDescriptors + where + memberTypeOrder : ExportDescriptor -> Nat + memberTypeOrder (MkClassExportDescriptor _) = 0 + memberTypeOrder (MkFieldExportDescriptor fieldExport) = if Static `elem` fieldExport.modifiers then 1 else 2 + memberTypeOrder (MkMethodExportDescriptor _) = 3 + memberTypeOrder _ = 4 + + go : (SortedMap Namespace (SortedMap String String), List ExportDescriptor) -> + List (Name, String) -> IO (SortedMap Namespace (SortedMap String String), List ExportDescriptor) + go acc [] = pure acc + go (imports, descriptors) ((idrisName, descriptor) :: rest) = do + asmState <- createAsmState globalState idrisName + (exportDescriptors, _) <- asm asmState (parseExportDescriptor idrisName descriptor) + case exportDescriptors of + [MkImportDescriptor name currentImports] => + let newImports = SortedMap.merge imports (SortedMap.singleton (getNamespace name) currentImports) + in go (newImports, descriptors) rest + _ => go (imports, exportDescriptors ++ descriptors) rest + +export +findClassAnnotation : String -> ClassExport -> Maybe Annotation +findClassAnnotation name classExport = + find (\(MkAnnotation currentName _) => name == currentName) classExport.annotations + +export +findAllArgsConstructor : ClassExport -> Maybe Annotation +findAllArgsConstructor = findClassAnnotation "AllArgsConstructor" + +export +findRequiredArgsConstructor : ClassExport -> Maybe Annotation +findRequiredArgsConstructor = findClassAnnotation "RequiredArgsConstructor" + +export +findNoArgsConstructor : ClassExport -> Maybe Annotation +findNoArgsConstructor = findClassAnnotation "NoArgsConstructor" + +hasFieldModifier : Access -> FieldExport -> Bool +hasFieldModifier modifier fieldExport = modifier `elem` fieldExport.modifiers + +export +isRequiredField : FieldExport -> Bool +isRequiredField = hasFieldModifier Final + +export +isTransientField : FieldExport -> Bool +isTransientField = hasFieldModifier Transient + +export +getFields : List ExportDescriptor -> List FieldExport +getFields descriptors = go [] descriptors where + go : List FieldExport -> List ExportDescriptor -> List FieldExport + go acc [] = acc + go acc (MkFieldExportDescriptor fieldExport :: rest) = + if hasFieldModifier Static fieldExport then go acc rest else go (fieldExport :: acc) rest + go acc (_ :: rest) = go acc rest + +knownAnnotations : List String +knownAnnotations = ["Data", "Getter", "Setter", "NoArgsConstructor", "RequiredArgsConstructor", + "AllArgsConstructor", "EqualsAndHashCode"] +export +isIdrisJvmAnnotation : Annotation -> Bool +isIdrisJvmAnnotation (MkAnnotation name _) = name `elem` knownAnnotations diff --git a/src/Compiler/Jvm/ExtPrim.idr b/src/Compiler/Jvm/ExtPrim.idr index f66cde2c1..88a47bc3f 100644 --- a/src/Compiler/Jvm/ExtPrim.idr +++ b/src/Compiler/Jvm/ExtPrim.idr @@ -2,13 +2,18 @@ module Compiler.Jvm.ExtPrim import Core.Context import Core.Name +import Debug.Trace ||| Extended primitives for the scheme backend, outside the standard set of primFn public export -data ExtPrim = JvmStaticMethodCall | JvmInstanceMethodCall +data ExtPrim = JvmStaticMethodCall | JvmInstanceMethodCall | JvmSuper + | JavaLambda | NewIORef | ReadIORef | WriteIORef | NewArray | ArrayGet | ArraySet - | GetField | SetField + | JvmNewArray | JvmSetArray | JvmGetArray | JvmArrayLength + | GetStaticField | SetStaticField + | GetInstanceField | SetInstanceField + | JvmClassLiteral | JvmInstanceOf | JvmRefEq | VoidElim | SysOS | SysCodegen | MakeFuture @@ -18,34 +23,61 @@ export Show ExtPrim where show JvmStaticMethodCall = "JvmStaticMethodCall" show JvmInstanceMethodCall = "JvmInstanceMethodCall" + show JavaLambda = "JavaLambda" + show JvmSuper = "JvmSuper" + show JvmClassLiteral = "JvmClassLiteral" + show JvmInstanceOf = "JvmInstanceOf" + show JvmRefEq = "JvmRefEq" show NewIORef = "NewIORef" show ReadIORef = "ReadIORef" show WriteIORef = "WriteIORef" show NewArray = "NewArray" show ArrayGet = "ArrayGet" show ArraySet = "ArraySet" - show GetField = "GetField" - show SetField = "SetField" + show JvmNewArray = "JvmNewArray" + show JvmSetArray = "JvmSetArray" + show JvmGetArray = "JvmGetArray" + show JvmArrayLength = "JvmArrayLength" + show GetStaticField = "GetStaticField" + show SetStaticField = "SetStaticField" + show GetInstanceField = "GetInstanceField" + show SetInstanceField = "SetInstanceField" show VoidElim = "VoidElim" show SysOS = "SysOS" show SysCodegen = "SysCodegen" show MakeFuture = "MakeFuture" show (Unknown n) = "Unknown " ++ show n +export +isSuper : Name -> Bool +isSuper (UN (Basic "prim__jvmSuper")) = True +isSuper n = False + ||| Match on a user given name to get the scheme primitive export toPrim : Name -> ExtPrim toPrim pn@(NS _ n) = cond [(n == UN (Basic "prim__jvmStatic"), JvmStaticMethodCall), (n == UN (Basic "prim__jvmInstance"), JvmInstanceMethodCall), + (isSuper n, JvmSuper), + (n == UN (Basic "prim__javaLambda"), JavaLambda), + (n == UN (Basic "prim__jvmClassLiteral"), JvmClassLiteral), + (n == UN (Basic "prim__jvmInstanceOf"), JvmInstanceOf), + (n == UN (Basic "prim__jvmRefEq"), JvmRefEq), (n == UN (Basic "prim__newIORef"), NewIORef), (n == UN (Basic "prim__readIORef"), ReadIORef), (n == UN (Basic "prim__writeIORef"), WriteIORef), (n == UN (Basic "prim__newArray"), NewArray), (n == UN (Basic "prim__arrayGet"), ArrayGet), (n == UN (Basic "prim__arraySet"), ArraySet), - (n == UN (Basic "prim__getField"), GetField), - (n == UN (Basic "prim__setField"), SetField), + (n == UN (Basic "prim__jvmNewArray"), JvmNewArray), + (n == UN (Basic "prim__jvmSetArray"), JvmSetArray), + (n == UN (Basic "prim__jvmGetArray"), JvmGetArray), + (n == UN (Basic "prim__jvmArrayLength"), JvmArrayLength), + (n == UN (Basic "prim__getStaticField"), GetStaticField), + (n == UN (Basic "prim__setStaticField"), SetStaticField), + (n == UN (Basic "prim__getInstanceField"), GetInstanceField), + (n == UN (Basic "prim__setInstanceField"), SetInstanceField), (n == UN (Basic "void"), VoidElim), (n == UN (Basic "prim__void"), VoidElim), (n == UN (Basic "prim__os"), SysOS), diff --git a/src/Compiler/Jvm/Foreign.idr b/src/Compiler/Jvm/Foreign.idr index feb64a98c..2c0900340 100644 --- a/src/Compiler/Jvm/Foreign.idr +++ b/src/Compiler/Jvm/Foreign.idr @@ -6,6 +6,7 @@ import Compiler.Inline import Core.Context import Core.Name +import Core.Reflect import Core.TT import Libraries.Data.SortedMap @@ -22,143 +23,97 @@ import Compiler.Jvm.Asm import Compiler.Jvm.ExtPrim import Compiler.Jvm.ShowUtil -namespace ForeignType - public export - data ForeignType - = AtomicForeignType InferredType - | FunctionForeignType - String -- (interfaceName: String) - String -- (methodName: String) - InferredFunctionType -- (interfaceMethodType: InferredFunctionType) - InferredFunctionType -- (implementationMethodType: InferredFunctionType) +getArity : Nat -> CFType -> Nat +getArity arity (CFFun argument _) = getArity (arity + 1) argument +getArity arity _ = arity - public export - getInferredType : ForeignType -> InferredType - getInferredType (FunctionForeignType interfaceName _ _ _) = IRef interfaceName - getInferredType (AtomicForeignType ty) = ty - -export -Show ForeignType where - show (AtomicForeignType ty) = show ty - show (FunctionForeignType interfaceName methodName interfaceMethodType implementationMethodType) = - interfaceName ++ "." ++ methodName ++ "#" ++ show interfaceMethodType ++ "#" ++ show implementationMethodType - -namespace ForeignImplementationType - public export - data ForeignImplementationType - = AtomicForeignImplementationType InferredType - | FunctionForeignImplementationType InferredFunctionType - - export - getInferredType : FC -> ForeignImplementationType -> Asm InferredType - getInferredType fc (AtomicForeignImplementationType ty) = Pure ty - getInferredType fc (FunctionForeignImplementationType ty) = Pure $ getFunctionInterface (length $ parameterTypes ty) - - mutual - parseCallbackType : FC -> List CFType -> CFType -> Asm ForeignImplementationType - parseCallbackType fc arguments (CFFun CFWorld returnType) = parseCallbackType fc arguments returnType - parseCallbackType fc arguments (CFFun nextArgument returnType) = - parseCallbackType fc (nextArgument :: arguments) returnType - parseCallbackType fc arguments returnType = do - argumentForeignTypes <- traverse parseInferredType (List.reverse arguments) - returnForeignType <- parseInferredType returnType - Pure $ FunctionForeignImplementationType (MkInferredFunctionType returnForeignType argumentForeignTypes) - where - parseInferredType : CFType -> Asm InferredType - parseInferredType ty = do - foreignType <- parse fc ty - inferredType <- getInferredType fc foreignType - Pure inferredType - - export - parse : FC -> CFType -> Asm ForeignImplementationType - parse _ CFUnit = Pure $ AtomicForeignImplementationType IVoid - parse _ CFInt = Pure $ AtomicForeignImplementationType IInt - parse _ CFInt8 = Pure $ AtomicForeignImplementationType IInt - parse _ CFInt16 = Pure $ AtomicForeignImplementationType IInt - parse _ CFInt32 = Pure $ AtomicForeignImplementationType IInt - parse _ CFInt64 = Pure $ AtomicForeignImplementationType ILong - parse _ CFUnsigned8 = Pure $ AtomicForeignImplementationType IInt - parse _ CFUnsigned16 = Pure $ AtomicForeignImplementationType IInt - parse _ CFUnsigned32 = Pure $ AtomicForeignImplementationType IInt - parse _ CFUnsigned64 = Pure $ AtomicForeignImplementationType ILong - parse _ CFString = Pure $ AtomicForeignImplementationType inferredStringType - parse _ CFDouble = Pure $ AtomicForeignImplementationType IDouble - parse _ CFInteger = Pure $ AtomicForeignImplementationType inferredBigIntegerType - parse _ CFChar = Pure $ AtomicForeignImplementationType IChar - parse _ CFWorld = Pure $ AtomicForeignImplementationType IInt - parse fc (CFIORes returnType) = parse fc returnType - parse fc (CFFun argument returnType) = parseCallbackType fc [argument] returnType - parse _ _ = Pure $ AtomicForeignImplementationType inferredObjectType - -export -Show ForeignImplementationType where - show (AtomicForeignImplementationType ty) = show ty - show (FunctionForeignImplementationType functionType) = show functionType - -export -throwExplicitFunctionDescriptorRequired : FC -> Asm a -throwExplicitFunctionDescriptorRequired fc = Throw fc ("Explicit function descriptor must be provided while " ++ - "passing idris functions to JVM functions") - -export -parseForeignCallbackDeclarationType : FC -> (descriptorParts : List String) -> Asm InferredFunctionType -parseForeignCallbackDeclarationType fc [] = throwExplicitFunctionDescriptorRequired fc -parseForeignCallbackDeclarationType _ [returnDescriptor] = Pure $ MkInferredFunctionType (parse returnDescriptor) [] -parseForeignCallbackDeclarationType _ (arg :: next) = - let (argumentTypesReversed, returnType) = go [] arg next - in Pure $ MkInferredFunctionType returnType (List.reverse argumentTypesReversed) - where - go : List InferredType -> String -> List String -> (List InferredType, InferredType) - go acc descriptor (nextArgument :: rest) = go (parse descriptor :: acc) nextArgument rest - go acc descriptor [] = (acc, parse descriptor) - -export -getForeignCallbackDeclarationType : FC -> ForeignImplementationType -> Asm ForeignType -getForeignCallbackDeclarationType fc (AtomicForeignImplementationType ty) = Pure $ AtomicForeignType ty -getForeignCallbackDeclarationType fc _ = throwExplicitFunctionDescriptorRequired fc - -{- - - Callbacks are represented as JVM functional interface types. For example, a foreign descriptor - - might have a callback like "jvm:foo:String java/util/function/ToIntFunction#applyAsInt#Object#Int Int". - - This descriptor provides the underlying functional interface method type for the second argument with the - - interface name, interface abstract method name, input and output types, all separated by "#". - -} export -parseForeignType : FC -> String -> ForeignImplementationType -> Asm ForeignType -parseForeignType fc descriptor implementationType = case toList $ String.split (== '#') descriptor of - [] => Throw fc $ "Invalid descriptor: " ++ descriptor - (interfaceName :: interfaceMethodName :: signatureParts) => - case implementationType of - AtomicForeignImplementationType _ => Throw fc ("Cannot pass non function argument as a JVM function") - FunctionForeignImplementationType implementationType => do - declarationType <- parseForeignCallbackDeclarationType fc signatureParts - Pure $ FunctionForeignType interfaceName interfaceMethodName declarationType implementationType - [_] => case implementationType of - FunctionForeignImplementationType _ => throwExplicitFunctionDescriptorRequired fc - _ => Pure $ AtomicForeignType $ parse descriptor +parse : FC -> CFType -> Asm InferredType +parse _ CFUnit = Pure IVoid +parse _ CFInt = Pure IInt +parse _ CFInt8 = Pure IByte +parse _ CFInt16 = Pure IShort +parse _ CFInt32 = Pure IInt +parse _ CFInt64 = Pure ILong +parse _ CFUnsigned8 = Pure IInt +parse _ CFUnsigned16 = Pure IInt +parse _ CFUnsigned32 = Pure IInt +parse _ CFUnsigned64 = Pure ILong +parse _ CFString = Pure inferredStringType +parse _ CFDouble = Pure IDouble +parse _ CFInteger = Pure inferredBigIntegerType +parse _ CFChar = Pure IChar +parse _ CFWorld = Pure IInt +parse fc (CFIORes returnType) = parse fc returnType +parse fc (CFStruct name fields) = Pure $ iref name [] +parse fc (CFFun argument _) = Pure $ getFunctionInterface (getArity 1 argument) +parse fc (CFUser name (ty :: _)) = + if name == builtin "Pair" then + case ty of + CFStruct name _ => + case words name of + [] => asmCrash ("Invalid Java lambda type at " ++ show fc) + (javaInterfaceName :: _) => Pure $ IRef javaInterfaceName Interface [] + _ => Pure inferredObjectType + else if name == arrayName then Pure $ IArray !(parse fc ty) + else Pure inferredObjectType +parse _ ty = Pure inferredObjectType export -parseForeignFunctionDescriptor : FC -> List String -> List ForeignImplementationType -> - InferredType -> Asm (String, String, InferredType, List ForeignType) -parseForeignFunctionDescriptor fc (functionDescriptor :: className :: _) argumentTypes returnType = +parseForeignFunctionDescriptor : FC -> List String -> List InferredType -> InferredType -> + Asm (String, String, InferredType, List InferredType) +parseForeignFunctionDescriptor fc (functionDescriptor :: descriptorParts) argumentTypes returnType = case String.break (== '(') functionDescriptor of (fn, "") => do - argumentDeclarationTypes <- traverse (getForeignCallbackDeclarationType fc) argumentTypes - Pure (className, fn, returnType, argumentDeclarationTypes) + className <- getClassName fn descriptorParts returnType argumentTypes + Pure (className, fn, returnType, argumentTypes) (fn, signature) => do - let descriptorsWithIdrisTypes = - zip - (toList $ String.split (== ' ') (assert_total $ strTail . fst $ break (== ')') signature)) - (argumentTypes ++ [AtomicForeignImplementationType returnType]) - (argumentTypesReversed, returnType) <- go [] descriptorsWithIdrisTypes - Pure (className, fn, returnType, List.reverse argumentTypesReversed) + let descriptors = + toList $ String.split (== ' ') (assert_total $ strTail . fst $ break (== ')') signature) + (argumentDeclarationTypesReversed, returnType) <- go [] descriptors + let argumentDeclarationTypes = List.reverse argumentDeclarationTypesReversed + className <- getClassName fn descriptorParts returnType argumentDeclarationTypes + Pure (className, fn, returnType, argumentDeclarationTypes) where - go : List ForeignType -> List (String, ForeignImplementationType) -> Asm (List ForeignType, InferredType) + + getInstanceMemberClass : (errorMessage: Lazy String) -> List InferredType -> Asm String + getInstanceMemberClass errorMessage ((IRef className _ _) :: _) = Pure className + getInstanceMemberClass errorMessage _ = Throw fc errorMessage + + getClassName : String -> List String -> InferredType -> List InferredType -> Asm String + getClassName memberName descriptorParts returnType argumentTypes = + let arity = length argumentTypes + in + if startsWith memberName "." then + getInstanceMemberClass + ("Instance method " ++ memberName ++ " must have first argument to be of reference type") + argumentTypes + else if startsWith memberName "#=" && arity >= 2 then + getInstanceMemberClass + ("Setter for instance field " ++ memberName ++ " must have first argument to be of reference type") + argumentTypes + else if startsWith memberName "#" && arity >= 1 then + getInstanceMemberClass + ("Getter for instance field " ++ memberName ++ " must have first argument to be of reference type") + argumentTypes + else + if memberName == "" + then + case returnType of + IRef className _ _ => Pure className + _ => Throw fc ("Constructor must return a reference type") + else + case descriptorParts of + (className :: _) => Pure className + _ => Throw fc + ("Static member " ++ memberName ++ " must have an explicit class name in foreign descriptor") + + + go : List InferredType -> List String -> Asm (List InferredType, InferredType) go acc [] = Pure (acc, IUnknown) - go acc ((returnTypeDesc, _) :: []) = Pure (acc, parse returnTypeDesc) - go acc ((argument, ty) :: rest) = do - foreignType <- parseForeignType fc argument ty + go acc (returnTypeDesc :: []) = Pure (acc, parse returnTypeDesc) + go acc (argument :: rest) = do + let foreignType = parse argument go (foreignType :: acc) rest parseForeignFunctionDescriptor fc descriptors _ _ = Throw fc $ "Invalid foreign descriptor: " ++ show descriptors @@ -173,35 +128,40 @@ getArgumentIndices : (arity: Int) -> List String -> IO (Map String Int) getArgumentIndices 0 _ = Map.newTreeMap {key=String} {value=Int} getArgumentIndices argIndex args = Map.fromList $ zip args [0 .. argIndex - 1] -getPrimMethodName : String -> String -getPrimMethodName "" = "prim__jvmStatic" -getPrimMethodName name = - assert_total $ if prim__strHead name == '.' then "prim__jvmInstance" else "prim__jvmStatic" +getPrimMethodName : (arity : Nat) -> String -> String +getPrimMethodName arity name = + cond + [ + (startsWith name ".", "prim__jvmInstance"), + (startsWith name "#=", if arity >= 2 then "prim__setInstanceField" else "prim__setStaticField"), + (startsWith name "#", if arity >= 1 then "prim__getInstanceField" else "prim__getStaticField") + ] + "prim__jvmStatic" isValidArgumentType : CFType -> Bool isValidArgumentType (CFUser (UN (Basic "Type")) _) = False isValidArgumentType _ = True -getIdrisJvmParameters : FC -> List CFType -> Asm (List (Nat, Bool, ForeignImplementationType)) +getIdrisJvmParameters : FC -> List CFType -> Asm (List (Nat, Bool, InferredType)) getIdrisJvmParameters fc idrisTypes = pure $ reverse !(go [] 0 idrisTypes) where - go : List (Nat, Bool, ForeignImplementationType) -> Nat -> List CFType -> - Asm (List (Nat, Bool, ForeignImplementationType)) + go : List (Nat, Bool, InferredType) -> Nat -> List CFType -> + Asm (List (Nat, Bool, InferredType)) go acc _ [] = pure acc go acc index (idrisType :: rest) = do jvmType <- parse fc idrisType let isValid = isValidArgumentType idrisType go ((index, isValid, jvmType) :: acc) (index + 1) rest -getJvmType : (Nat, Bool, ForeignImplementationType) -> ForeignImplementationType +getJvmType : (Nat, Bool, InferredType) -> InferredType getJvmType (_, _, jvmType) = jvmType -shouldPassToForeign : (CFType, Nat, Bool, ForeignImplementationType) -> Bool +shouldPassToForeign : (CFType, Nat, Bool, InferredType) -> Bool shouldPassToForeign (_, _, shouldPass, _) = shouldPass -getArgumentNameAndTypes : FC -> List InferredType -> List (Nat, Bool, ForeignImplementationType) -> +getArgumentNameAndTypes : FC -> List InferredType -> List (Nat, Bool, InferredType) -> Asm (List (String, InferredType)) getArgumentNameAndTypes fc descriptorTypes params = reverse <$> go [] descriptorTypes params where - go : List (String, InferredType) -> List InferredType -> List (Nat, Bool, ForeignImplementationType) -> + go : List (String, InferredType) -> List InferredType -> List (Nat, Bool, InferredType) -> Asm (List (String, InferredType)) go acc [] _ = pure acc -- Ignore any additional arguments from Idris go acc _ [] = Throw fc "Foreign descriptor and Idris types do not match" @@ -222,13 +182,10 @@ inferForeign programName idrisName fc foreignDescriptors argumentTypes returnTyp let arityNat = length argumentTypes let isNilArity = arityNat == 0 jvmDescriptor <- findJvmDescriptor fc idrisName foreignDescriptors - jvmReturnType <- getInferredType fc !(parse fc returnType) - (foreignFunctionClassName, foreignFunctionName, jvmReturnType, jvmArgumentForeignTypesFromDescriptor) <- + jvmReturnType <- parse fc returnType + (foreignFunctionClassName, foreignFunctionName, jvmReturnType, jvmArgumentTypesFromDescriptor) <- parseForeignFunctionDescriptor fc jvmDescriptor jvmArgumentTypes jvmReturnType - -- TODO: Do not discard Java lambda type descriptor - let jvmArgumentTypesFromDescriptor = getInferredType <$> jvmArgumentForeignTypesFromDescriptor - scopeIndex <- newScopeIndex let arity = the Int $ cast arityNat let argumentNames = @@ -236,15 +193,17 @@ inferForeign programName idrisName fc foreignDescriptors argumentTypes returnTyp argumentNameAndTypes <- getArgumentNameAndTypes fc jvmArgumentTypesFromDescriptor jvmArguments let methodReturnType = if isNilArity then delayedType else inferredObjectType let inferredFunctionType = MkInferredFunctionType methodReturnType (replicate arityNat inferredObjectType) - scopes <- LiftIo $ JList.new {a=Scope} + scopes <- LiftIo $ ArrayList.new {elemTy=Scope} + let extPrimName = NS (mkNamespace "") $ UN $ Basic $ + getPrimMethodName (length argumentNameAndTypes) foreignFunctionName let externalFunctionBody = - NmExtPrim fc (NS (mkNamespace "") $ UN $ Basic $ getPrimMethodName foreignFunctionName) [ + NmExtPrim fc extPrimName [ NmCon fc (UN $ Basic $ createExtPrimTypeSpec jvmReturnType) DATACON Nothing [], NmPrimVal fc (Str $ foreignFunctionClassName ++ "." ++ foreignFunctionName), getJvmExtPrimArguments $ zip validIdrisTypes argumentNameAndTypes, NmPrimVal fc WorldVal] let functionBody = if isNilArity then NmDelay fc LLazy externalFunctionBody else externalFunctionBody - let function = MkFunction jname inferredFunctionType scopes 0 jvmClassAndMethodName functionBody + let function = MkFunction jname inferredFunctionType (subtyping scopes) 0 jvmClassAndMethodName functionBody setCurrentFunction function LiftIo $ AsmGlobalState.addFunction !getGlobalState jname function let parameterTypes = parameterTypes inferredFunctionType diff --git a/src/Compiler/Jvm/FunctionTree.idr b/src/Compiler/Jvm/FunctionTree.idr index c602d6a60..4e88be485 100644 --- a/src/Compiler/Jvm/FunctionTree.idr +++ b/src/Compiler/Jvm/FunctionTree.idr @@ -83,7 +83,7 @@ parameters (defs: Map String NamedDef) findDef : Name -> Maybe NamedDef findDef name = let nameStr = jvmSimpleName name - in unsafePerformIO $ Map.get defs nameStr + in nullableToMaybe $ unsafePerformIO $ Map.get defs nameStr buildFunctionTree : SortedSet Name -> Name -> (SortedSet Name, Tree Name) buildFunctionTree visitedSoFar name = diff --git a/src/Compiler/Jvm/InferredType.idr b/src/Compiler/Jvm/InferredType.idr index a8e34a700..1c686432a 100644 --- a/src/Compiler/Jvm/InferredType.idr +++ b/src/Compiler/Jvm/InferredType.idr @@ -1,45 +1,101 @@ module Compiler.Jvm.InferredType +import Compiler.Jvm.Jname +import Core.CompileExpr +import Core.Core +import Core.Name +import Data.List1 import Data.String - -public export -data InferredType = IBool | IByte | IChar | IShort | IInt | ILong | IFloat | IDouble | IRef String - | IArray InferredType | IVoid | IUnknown - -export -Eq InferredType where - IBool == IBool = True - IByte == IByte = True - IChar == IChar = True - IShort == IShort = True - IInt == IInt = True - ILong == ILong = True - IFloat == IFloat = True - IDouble == IDouble = True - (IRef ty1) == (IRef ty2) = ty1 == ty2 - (IArray elemTy1) == (IArray elemTy2) = elemTy1 == elemTy2 - IUnknown == IUnknown = True - IVoid == IVoid = True - _ == _ = False - -export -Show InferredType where - show IBool = "boolean" - show IByte = "byte" - show IChar = "char" - show IShort = "short" - show IInt = "int" - show ILong = "long" - show IFloat = "float" - show IDouble = "double" - show (IRef clsName) = clsName - show (IArray elemTy) = "Array " ++ show elemTy - show IUnknown = "unknown" - show IVoid = "void" +import System.FFI +import Data.Maybe + +mutual + public export + data JavaReferenceType = Class | Interface + + public export + data InferredType = IBool | IByte | IChar | IShort | IInt | ILong | IFloat | IDouble + | IRef String JavaReferenceType (List InferredType) + | IArray InferredType | IVoid + | IFunction JavaLambdaType + | IUnknown + + public export + record InferredFunctionType where + constructor MkInferredFunctionType + returnType : InferredType + parameterTypes : List InferredType + + public export + record JavaLambdaType where + constructor MkJavaLambdaType + javaInterface: InferredType + methodName: String + methodType: InferredFunctionType + implementationType: InferredFunctionType + +mutual + export + Eq InferredFunctionType where + (MkInferredFunctionType returnType1 argumentTypes1) == + (MkInferredFunctionType returnType2 argumentTypes2) = + assert_total $ returnType1 == returnType2 && argumentTypes1 == argumentTypes2 + + export + Eq JavaLambdaType where + (MkJavaLambdaType intf1 method1 methodType1 implementationType1) == + (MkJavaLambdaType intf2 method2 methodType2 implementationType2) = intf1 == intf2 && method1 == method2 && + methodType1 == methodType2 && implementationType1 == implementationType2 + + + export + Eq InferredType where + IBool == IBool = True + IByte == IByte = True + IChar == IChar = True + IShort == IShort = True + IInt == IInt = True + ILong == ILong = True + IFloat == IFloat = True + IDouble == IDouble = True + (IRef ty1 _ params1) == (IRef ty2 _ params2) = assert_total (ty1 == ty2 && params1 == params2) + (IArray elemTy1) == (IArray elemTy2) = elemTy1 == elemTy2 + (IFunction javaLambdaType1) == (IFunction javaLambdaType2) = assert_total $ javaLambdaType1 == javaLambdaType2 + IUnknown == IUnknown = True + IVoid == IVoid = True + _ == _ = False + +mutual + export + Show InferredFunctionType where + show (MkInferredFunctionType returnType argumentTypes) = + assert_total $ showSep "⟶" (show <$> (argumentTypes ++ [returnType])) + + export + Show JavaLambdaType where + show (MkJavaLambdaType intf method methodType implementationType) = + showSep " " ["Lambda", show intf, method, show methodType, show implementationType] + + export + Show InferredType where + show IBool = "boolean" + show IByte = "byte" + show IChar = "char" + show IShort = "short" + show IInt = "int" + show ILong = "long" + show IFloat = "float" + show IDouble = "double" + show (IRef clsName _ []) = clsName + show (IRef clsName _ typeParams) = assert_total (clsName ++ "<" ++ showSep ", " (show <$> typeParams) ++ ">") + show (IArray elemTy) = "Array " ++ show elemTy + show (IFunction lambdaTy) = assert_total $ "Function " ++ show lambdaTy + show IUnknown = "unknown" + show IVoid = "void" export inferredObjectType : InferredType -inferredObjectType = IRef "java/lang/Object" +inferredObjectType = IRef "java/lang/Object" Class [] %inline public export @@ -48,7 +104,7 @@ bigIntegerClass = "java/math/BigInteger" export inferredBigIntegerType : InferredType -inferredBigIntegerType = IRef bigIntegerClass +inferredBigIntegerType = IRef bigIntegerClass Class [] %inline public export @@ -57,26 +113,26 @@ stringClass = "java/lang/String" export inferredStringType : InferredType -inferredStringType = IRef stringClass +inferredStringType = IRef stringClass Class [] export inferredLambdaType : InferredType -inferredLambdaType = IRef "java/util/function/Function" +inferredLambdaType = IRef "java/util/function/Function" Interface [] export function2Type : InferredType -function2Type = IRef "java/util/function/BiFunction" +function2Type = IRef "java/util/function/BiFunction" Interface [] export getFunctionInterface : (arity: Nat) -> InferredType getFunctionInterface 1 = inferredLambdaType getFunctionInterface 2 = function2Type -getFunctionInterface arity = IRef ("io/github/mmhelloworld/idrisjvm/runtime/Function" ++ show arity) +getFunctionInterface arity = IRef ("io/github/mmhelloworld/idrisjvm/runtime/Function" ++ show arity) Interface [] %inline public export inferredForkJoinTaskType : InferredType -inferredForkJoinTaskType = IRef "java/util/concurrent/ForkJoinTask" +inferredForkJoinTaskType = IRef "java/util/concurrent/ForkJoinTask" Class [] %inline public export @@ -86,7 +142,7 @@ arrayListClass = "java/util/ArrayList" %inline public export arrayListType : InferredType -arrayListType = IRef arrayListClass +arrayListType = IRef arrayListClass Class [] %inline public export @@ -100,7 +156,7 @@ idrisListClass = "io/github/mmhelloworld/idrisjvm/runtime/IdrisList" export idrisListType : InferredType -idrisListType = IRef idrisListClass +idrisListType = IRef idrisListClass Class [] %inline public export @@ -109,7 +165,7 @@ idrisNilClass = "io/github/mmhelloworld/idrisjvm/runtime/IdrisList$Nil" export idrisNilType : InferredType -idrisNilType = IRef idrisNilClass +idrisNilType = IRef idrisNilClass Class [] %inline public export @@ -118,7 +174,7 @@ idrisConsClass = "io/github/mmhelloworld/idrisjvm/runtime/IdrisList$Cons" export idrisConsType : InferredType -idrisConsType = IRef idrisConsClass +idrisConsType = IRef idrisConsClass Class [] %inline public export @@ -127,7 +183,7 @@ idrisNothingClass = "io/github/mmhelloworld/idrisjvm/runtime/Maybe$Nothing" export idrisNothingType : InferredType -idrisNothingType = IRef idrisNothingClass +idrisNothingType = IRef idrisNothingClass Class [] %inline public export @@ -136,7 +192,11 @@ idrisJustClass = "io/github/mmhelloworld/idrisjvm/runtime/Maybe$Just" export idrisJustType : InferredType -idrisJustType = IRef idrisJustClass +idrisJustType = IRef idrisJustClass Class [] + +export +idrisMaybeType : InferredType +idrisMaybeType = IRef "io/github/mmhelloworld/idrisjvm/runtime/Maybe" Class [] %inline public export @@ -167,7 +227,7 @@ delayedClass = getRuntimeClass "Delayed" export delayedType : InferredType -delayedType = IRef delayedClass +delayedType = IRef delayedClass Interface [] %inline public export @@ -186,15 +246,15 @@ refClass = getRuntimeClass "Ref" export refType : InferredType -refType = IRef refClass +refType = IRef refClass Class [] export idrisObjectType : InferredType -idrisObjectType = IRef idrisObjectClass +idrisObjectType = IRef idrisObjectClass Interface [] public export isRefType : InferredType -> Bool -isRefType (IRef _) = True +isRefType (IRef _ _ _) = True isRefType _ = False public export @@ -208,12 +268,89 @@ public export Monoid InferredType where neutral = IUnknown +export +%foreign "jvm:.indexOf(java/lang/String int int),java/lang/String" +indexOf : String -> Int -> Int + +export +%foreign "jvm:.replaceAll,java/lang/String" +replaceAll : String -> String -> String -> String + +export +iref : String -> List InferredType -> InferredType +iref className typeParams = + let isInterface = "i:" `isPrefixOf` className + referenceType = if isInterface then Interface else Class + hashIndex = indexOf className (cast '#') -- old way of explicitly giving Java lambda descriptor + startIndex = if isInterface then 2 else 0 + endIndex = if hashIndex == -1 then length className else cast hashIndex + in IRef (substr startIndex endIndex className) referenceType typeParams + export stripInterfacePrefix : InferredType -> InferredType -stripInterfacePrefix (IRef className) = - IRef $ if "i:" `isPrefixOf` className then substr 2 (length className) className else className +stripInterfacePrefix (IRef className _ params) = iref className params stripInterfacePrefix ty = ty +public export +%foreign "jvm:.startsWith(java/lang/String java/lang/String boolean),java/lang/String" +startsWith : String -> String -> Bool + +public export +%foreign "jvm:.endsWith(java/lang/String java/lang/String boolean),java/lang/String" +endsWith : String -> String -> Bool + +export +%foreign + jvm' "io/github/mmhelloworld/idrisjvm/assembler/IdrisName" "getIdrisConstructorClassName" + "String" "String" +getIdrisConstructorClassName : String -> String + +data GenericTypeToken = Ident String | TypeParamStart | TypeParamEnd + +export +Show GenericTypeToken where + show (Ident ident) = ident + show TypeParamStart = "<" + show TypeParamEnd = ">" + +mutual + tokenize : String -> List GenericTypeToken + tokenize str = reverse $ go [] str where + go : List GenericTypeToken -> String -> List GenericTypeToken + go acc "" = acc + go acc descriptor = case String.break (\c => c == '<' || c == ',' || c == '>' || c == ' ') descriptor of + ("", "") => acc + (typeName, "") => Ident typeName :: acc + (typeName, rest) => + let first = assert_total (prim__strHead rest) + newRest = assert_total $ strTail rest + in if first == '<' || first == '>' then + let delim = if first == '<' then TypeParamStart else TypeParamEnd + newAcc = if typeName == "" then delim :: acc else delim :: Ident typeName :: acc + in go newAcc newRest + else if typeName == "" then go acc newRest else go (Ident typeName :: acc) newRest + + goParseGenericType : List GenericTypeToken -> (Maybe InferredType, List GenericTypeToken) + goParseGenericType (Ident typeName :: TypeParamStart :: rest) = + let (typeParams, newRest) = parseTypeParams [] rest + in (Just $ iref typeName $ reverse typeParams, newRest) + goParseGenericType (Ident typeName :: rest) = (Just $ iref typeName [], rest) + goParseGenericType rest = (Nothing, rest) + + parseTypeParams : List InferredType -> List GenericTypeToken -> (List InferredType, List GenericTypeToken) + parseTypeParams acc [] = (acc, []) + parseTypeParams acc (TypeParamEnd :: rest) = (acc, rest) + parseTypeParams acc tokens = + let (typeParam, newRest) = goParseGenericType tokens + in parseTypeParams (maybe acc (flip (::) acc) typeParam) newRest + + export + parseGenericType : String -> Maybe InferredType + parseGenericType descriptor = fst $ goParseGenericType $ tokenize descriptor + +throwInvalidDescriptor : String -> a +throwInvalidDescriptor desc = assert_total $ idris_crash ("Invalid type descriptor: " ++ desc) + export parse : String -> InferredType parse "boolean" = IBool @@ -227,25 +364,43 @@ parse "double" = IDouble parse "String" = inferredStringType parse "BigInteger" = inferredBigIntegerType parse "void" = IVoid -parse className = IRef className - -export -createExtPrimTypeSpec : InferredType -> String -createExtPrimTypeSpec IBool = "Bool" -createExtPrimTypeSpec IByte = "Byte" -createExtPrimTypeSpec IShort = "Short" -createExtPrimTypeSpec IInt = "Int" -createExtPrimTypeSpec IChar = "Char" -createExtPrimTypeSpec ILong = "long" -createExtPrimTypeSpec IFloat = "float" -createExtPrimTypeSpec IDouble = "Double" -createExtPrimTypeSpec (IArray ty) = "[" ++ createExtPrimTypeSpec ty -createExtPrimTypeSpec IVoid = "void" -createExtPrimTypeSpec IUnknown = createExtPrimTypeSpec inferredObjectType -createExtPrimTypeSpec (IRef ty) = ty +parse "[" = throwInvalidDescriptor "[" +parse desc = + if startsWith desc "[" + then IArray (parse (assert_total (strTail desc))) + else fromMaybe (throwInvalidDescriptor desc) $ parseGenericType desc + +mutual + createExtPrimTypeSpecFn : InferredFunctionType -> String + createExtPrimTypeSpecFn (MkInferredFunctionType returnType parameterTypes) = + showSep "⟶" (createExtPrimTypeSpec <$> parameterTypes) ++ "⟶" ++ createExtPrimTypeSpec returnType + + createTypeParamsSpec : List InferredType -> String + createTypeParamsSpec [] = "" + createTypeParamsSpec typeParams = "<" ++ showSep ", " (createExtPrimTypeSpec <$> typeParams) ++ ">" + + export + createExtPrimTypeSpec : InferredType -> String + createExtPrimTypeSpec IBool = "Bool" + createExtPrimTypeSpec IByte = "Byte" + createExtPrimTypeSpec IShort = "Short" + createExtPrimTypeSpec IInt = "Int" + createExtPrimTypeSpec IChar = "Char" + createExtPrimTypeSpec ILong = "long" + createExtPrimTypeSpec IFloat = "float" + createExtPrimTypeSpec IDouble = "Double" + createExtPrimTypeSpec IVoid = "void" + createExtPrimTypeSpec (IRef ty Interface params) = "i:" ++ ty ++ createTypeParamsSpec params + createExtPrimTypeSpec (IRef ty _ params) = ty ++ createTypeParamsSpec params + createExtPrimTypeSpec (IFunction (MkJavaLambdaType intf method methodType implementationType)) = + "λ" ++ showSep "," [createExtPrimTypeSpec intf, method, createExtPrimTypeSpecFn methodType, + createExtPrimTypeSpecFn implementationType] + createExtPrimTypeSpec (IArray ty) = "[" ++ createExtPrimTypeSpec ty + createExtPrimTypeSpec IUnknown = createExtPrimTypeSpec inferredObjectType export isObjectType : InferredType -> Bool isObjectType IUnknown = True -isObjectType (IRef "java/lang/Object") = True +isObjectType (IRef "java/lang/Object" _ _) = True isObjectType _ = False + diff --git a/src/Compiler/Jvm/Jname.idr b/src/Compiler/Jvm/Jname.idr index 48223f1a6..db76dfe7c 100644 --- a/src/Compiler/Jvm/Jname.idr +++ b/src/Compiler/Jvm/Jname.idr @@ -71,9 +71,6 @@ jvmSimpleName = getSimpleName . jvmName jvmIdrisMainMethodName : String jvmIdrisMainMethodName = "jvm$idrisMain" -jvmIdrisMainClass : String -> String -jvmIdrisMainClass rootPackage = rootPackage ++ "/Main" - export idrisMainFunctionName : String -> Name idrisMainFunctionName rootPackage = NS (mkNamespace $ rootPackage ++ ".Main") (UN $ Basic jvmIdrisMainMethodName) diff --git a/src/Compiler/Jvm/MockAsm.idr b/src/Compiler/Jvm/MockAsm.idr index 1c3cda9dd..918c8da7b 100644 --- a/src/Compiler/Jvm/MockAsm.idr +++ b/src/Compiler/Jvm/MockAsm.idr @@ -70,23 +70,24 @@ mockRunAsm state (ClassCodeStart version access className sig parent intf anns) log $ unwords [ "classCodeStart", show version, - show (accessNum access), + show (show access), className, (fromMaybe "" sig), parent] mockRunAsm state (CreateClass opts) = assemble state $ log $ "createClass " ++ show opts -mockRunAsm state (CreateField accs sourceFileName className fieldName desc sig fieldInitialValue) = assemble state $ do - let jaccs = sum $ accessNum <$> accs - log $ unwords [ - "createField", - show jaccs, - sourceFileName, - className, - fieldName, - desc, - fromMaybe "" sig, - (objectToString $ maybeToNullable (toJFieldInitialValue <$> fieldInitialValue))] +mockRunAsm state (CreateField accs sourceFileName className fieldName desc sig fieldInitialValue annotations) = + assemble state $ do + let jaccs = sum $ accessNum <$> accs + log $ unwords [ + "createField", + show jaccs, + sourceFileName, + className, + fieldName, + desc, + fromMaybe "" sig, + (objectToString $ maybeToNullable (toJFieldInitialValue <$> fieldInitialValue))] mockRunAsm state (CreateLabel label) = assemble state $ pure () @@ -108,6 +109,7 @@ mockRunAsm state (CreateIdrisConstructorClass className isStringConstructor cons mockRunAsm state D2i = assemble state $ log "d2i" mockRunAsm state D2f = assemble state $ log "d2f" +mockRunAsm state D2l = assemble state $ log "d2l" mockRunAsm state Dadd = assemble state $ log "dadd" mockRunAsm state Dcmpl = assemble state $ log "dcmpl" mockRunAsm state Dcmpg = assemble state $ log "dcmpg" @@ -194,6 +196,8 @@ mockRunAsm state (Ificmple label) = assemble state $ log $ "ificmple " ++ label mockRunAsm state (Ificmplt label) = assemble state $ log $ "ificmplt " ++ label +mockRunAsm state (Ifacmpne label) = + assemble state $ log $ "ifacmpne " ++ label mockRunAsm state (Ificmpne label) = assemble state $ log $ "ificmpne " ++ label mockRunAsm state (Ifle label) = @@ -235,19 +239,17 @@ mockRunAsm state Irem = assemble state $ log "irem" mockRunAsm state Ireturn = assemble state $ log "ireturn" mockRunAsm state Ishl = assemble state $ log "ishl" mockRunAsm state Ishr = assemble state $ log "ishr" -mockRunAsm state (Istore n) = assemble state $ - log $ "istore " ++ show n +mockRunAsm state (Istore n) = assemble state $ log $ "istore " ++ show n mockRunAsm state Isub = assemble state $ log "isub" mockRunAsm state Iushr = assemble state $ log "iushr" mockRunAsm state L2d = assemble state $ log "l2d" mockRunAsm state L2i = assemble state $ log "l2i" mockRunAsm state (LabelStart label) = assemble state $ log (label ++ ":") mockRunAsm state Ladd = assemble state $ log "ladd" -mockRunAsm state Land = assemble state $ log "land" mockRunAsm state Laload = assemble state $ log "laload" +mockRunAsm state Land = assemble state $ log "land" mockRunAsm state Lastore = assemble state $ log "lastore" -mockRunAsm state Lor = assemble state $ log "lor" -mockRunAsm state Lxor = assemble state $ log "lxor" +mockRunAsm state Lcmp = assemble state $ log "lcmp" mockRunAsm state Lcompl = assemble state $ log "lcompl" mockRunAsm state (Ldc (TypeConst ty)) = @@ -267,13 +269,6 @@ mockRunAsm state (Lload n) = assemble state $ log $ "lload " ++ show n mockRunAsm state Lmul = assemble state $ log "lmul" mockRunAsm state Lneg = assemble state $ log "lneg" -mockRunAsm state (LookupSwitch defaultLabel labels cases) = assemble state $ do - let jcases = integerValueOf <$> cases - log $ unwords [ - "lookupSwitch", - defaultLabel, - (objectToString (the Object $ believe_me labels)), - (objectToString (the Object $ believe_me jcases))] mockRunAsm state (LocalVariable name descriptor signature startLabel endLabel index) = assemble state $ log $ unwords [ @@ -284,6 +279,15 @@ mockRunAsm state (LocalVariable name descriptor signature startLabel endLabel in startLabel, endLabel, show index] +mockRunAsm state (LookupSwitch defaultLabel labels cases) = assemble state $ do + let jcases = integerValueOf <$> cases + log $ unwords [ + "lookupSwitch", + defaultLabel, + (objectToString (the Object $ believe_me labels)), + (objectToString (the Object $ believe_me jcases))] + +mockRunAsm state Lor = assemble state $ log "lor" mockRunAsm state Lrem = assemble state $ log "lrem" mockRunAsm state Lreturn = assemble state $ log "lreturn" @@ -293,13 +297,14 @@ mockRunAsm state (Lstore n) = assemble state $ log $ "lstore " ++ show n mockRunAsm state Lsub = assemble state $ log "lsub" mockRunAsm state Lushr = assemble state $ log "lushr" +mockRunAsm state Lxor = assemble state $ log "lxor" mockRunAsm state (MaxStackAndLocal stack local) = assemble state $ log $ "maxStackAndLocal " ++ show stack ++ " " ++ show local mockRunAsm state MethodCodeStart = assemble state $ log "methodCodeStart" mockRunAsm state MethodCodeEnd = assemble state $ do log "methodCodeEnd" - log $ "***********************************" + log $ "**********************************" mockRunAsm state (Multianewarray desc dims) = assemble state $ log $ unwords ["multiANewArray", desc, show dims] mockRunAsm state (New cname) = assemble state $ @@ -321,4 +326,3 @@ mockRunAsm st (Pure value) = pure (value, st) mockRunAsm st (Bind action f) = do (result, nextSt) <- mockRunAsm st action mockRunAsm nextSt $ f result -mockRunAsm state action = pure (believe_me $ crash "Unsupported action", state) diff --git a/src/Compiler/Jvm/Optimizer.idr b/src/Compiler/Jvm/Optimizer.idr index b87f6a310..54e790c15 100644 --- a/src/Compiler/Jvm/Optimizer.idr +++ b/src/Compiler/Jvm/Optimizer.idr @@ -10,6 +10,7 @@ import Control.Monad.State import Core.Context import Core.Name +import Core.Reflect import Core.TT import Libraries.Data.SortedMap @@ -18,36 +19,19 @@ import Data.List import Data.Maybe import Data.String import Data.Vect +import Debug.Trace import Compiler.Jvm.Asm import Compiler.Jvm.ExtPrim import Compiler.Jvm.Foreign import Compiler.Jvm.InferredType import Compiler.Jvm.Jname +import Compiler.Jvm.MockAsm import Compiler.Jvm.ShowUtil %hide Core.Context.Context.Constructor.arity - -isBoolTySpec : String -> Name -> Bool -isBoolTySpec "Prelude" (UN (Basic "Bool")) = True -isBoolTySpec "Prelude.Basics" (UN (Basic "Bool")) = True -isBoolTySpec _ _ = False - -export -tySpec : NamedCExp -> Asm InferredType -tySpec (NmCon fc (UN (Basic "Int")) _ _ []) = pure IInt -tySpec (NmCon fc (UN (Basic "Integer")) _ _ []) = pure inferredBigIntegerType -tySpec (NmCon fc (UN (Basic "String")) _ _ []) = pure inferredStringType -tySpec (NmCon fc (UN (Basic "Double")) _ _ []) = pure IDouble -tySpec (NmCon fc (UN (Basic "Char")) _ _ []) = pure IChar -tySpec (NmCon fc (UN (Basic "Bool")) _ _ []) = pure IBool -tySpec (NmCon fc (UN (Basic "long")) _ _ []) = pure ILong -tySpec (NmCon fc (UN (Basic "void")) _ _ []) = pure IVoid -tySpec (NmCon fc (UN (Basic ty)) _ _ []) = pure $ IRef ty -tySpec (NmCon fc (NS namespaces n) _ _ []) = cond - [(n == UN (Basic "Unit"), pure IVoid), - (isBoolTySpec (show namespaces) n, pure IBool)] (pure inferredObjectType) -tySpec ty = pure inferredObjectType +%hide Compiler.TailRec.Function.fc +%hide Compiler.TailRec.TcFunction.fc namespace InferredPrimType export @@ -485,9 +469,9 @@ getSamDesc Function5Lambda = getMethodDescriptor $ MkInferredFunctionType inferredObjectType $ replicate 5 inferredObjectType export -getLambdaInterfaceType : LambdaType -> InferredType -> InferredType -getLambdaInterfaceType DelayedLambda returnType = delayedType -getLambdaInterfaceType _ returnType = inferredLambdaType +getLambdaInterfaceType : LambdaType -> InferredType +getLambdaInterfaceType DelayedLambda = delayedType +getLambdaInterfaceType _ = inferredLambdaType export getLambdaImplementationMethodReturnType : LambdaType -> InferredType @@ -562,11 +546,81 @@ createNewVariable variablePrefix ty = do variable <- generateVariable variablePrefix ignore $ addVariableType variable ty +export +isIoAction : NamedCExp -> Bool +isIoAction (NmCon _ (UN (Basic "->")) _ _ [argumentType, returnType]) = isIoAction returnType +isIoAction (NmApp _ (NmRef _ name) _) = name == primio "PrimIO" +isIoAction (NmCon _ name _ _ _) = name == primio "IORes" +isIoAction (NmLam fc arg expr) = isIoAction expr +isIoAction expr = False + +voidTypeExpr : NamedCExp +voidTypeExpr = NmCon emptyFC (UN (Basic "void")) TYCON Nothing [] + +export +getJavaLambdaType : FC -> List NamedCExp -> Asm JavaLambdaType +getJavaLambdaType fc [functionType, javaInterfaceType, _] = + do + implementationType <- parseFunctionType functionType + (interfaceTy, methodName, methodType) <- parseJavaInterfaceType javaInterfaceType + Pure $ MkJavaLambdaType interfaceTy methodName methodType implementationType + where + parseFunctionType: NamedCExp -> Asm InferredFunctionType + parseFunctionType functionType = do + types <- go [] functionType + case types of + [] => asmCrash ("Invalid Java lambda at " ++ show fc ++ ": " ++ show functionType) + (returnType :: argTypes) => Pure $ MkInferredFunctionType returnType (reverse argTypes) + where + go : List InferredType -> NamedCExp -> Asm (List InferredType) + go acc (NmCon _ (UN (Basic "->")) _ _ [argTy, lambdaTy]) = do + argInferredTy <- tySpec argTy + restInferredTypes <- go acc lambdaTy + Pure (restInferredTypes ++ (argInferredTy :: acc)) + go acc (NmLam fc arg expr) = go acc expr + go acc expr@(NmApp _ (NmRef _ name) [arg]) = go (IInt :: acc) (if name == primio "PrimIO" then arg else expr) + go acc expr = Pure (!(tySpec expr) :: acc) + + throwExpectedStructAtPos : Asm a + throwExpectedStructAtPos = + asmCrash ("Expected a struct containing interface name and method separated by space at " ++ show fc) + + throwExpectedStruct : String -> Asm a + throwExpectedStruct name = + asmCrash ("Expected a struct containing interface name and method separated by space at " ++ + show fc ++ " but found " ++ name) + + parseJavaInterfaceType : NamedCExp -> Asm (InferredType, String, InferredFunctionType) + parseJavaInterfaceType expr@(NmCon _ name _ _ [interfaceType, methodTypeExp]) = + if name == builtin "Pair" then + case interfaceType of + NmCon _ name _ _ (NmPrimVal _ (Str namePartsStr) :: _) => + if name == structName + then case words namePartsStr of + (interfaceName :: methodName :: _) => do + methodType <- parseFunctionType methodTypeExp + Pure (IRef interfaceName Interface [], methodName, methodType) + _ => asmCrash ("Expected interface name and method separated by space at " ++ show fc ++ ": " ++ + namePartsStr) + else throwExpectedStruct namePartsStr + _ => throwExpectedStructAtPos + else asmCrash ("Expected a tuple containing interface type and method type but found: " ++ showNamedCExp 0 expr) + parseJavaInterfaceType (NmApp _ (NmRef _ name) _) = do + (_, MkNmFun _ def) <- getFcAndDefinition (jvmSimpleName name) + | _ => asmCrash ("Expected a function returning a tuple containing interface type and method type at " ++ + show fc) + parseJavaInterfaceType def + parseJavaInterfaceType (NmDelay _ _ expr) = parseJavaInterfaceType expr + parseJavaInterfaceType expr = asmCrash ("Expected a tuple containing interface type and method type but found: " ++ showNamedCExp 0 expr) + +getJavaLambdaType fc exprs = asmCrash ("Invalid Java lambda at " ++ show fc ++ ": " ++ show exprs) + mutual inferExpr : InferredType -> NamedCExp -> Asm InferredType inferExpr exprTy (NmDelay _ _ expr) = inferExprLam AppliedLambdaUnknown Nothing Nothing expr inferExpr exprTy expr@(NmLocal _ var) = addVariableType (jvmSimpleName var) exprTy inferExpr exprTy (NmRef _ name) = pure exprTy + inferExpr exprTy app@(NmApp _ (NmRef _ name) args) = inferExprApp exprTy app inferExpr _ (NmApp fc (NmLam _ var body) [expr]) = inferExprLam (getAppliedLambdaType fc) (Just expr) (Just var) body inferExpr _ (NmLam _ var body) = inferExprLam AppliedLambdaUnknown Nothing (Just var) body @@ -697,16 +751,25 @@ mutual inferExtPrimArg (arg, ty) = inferExpr ty arg inferExtPrim : FC -> InferredType -> ExtPrim -> List NamedCExp -> Asm InferredType + inferExtPrim fc returnType GetStaticField descriptors = inferExtPrim fc returnType JvmStaticMethodCall descriptors + inferExtPrim fc returnType SetStaticField descriptors = inferExtPrim fc returnType JvmStaticMethodCall descriptors + inferExtPrim fc returnType GetInstanceField descriptors = inferExtPrim fc returnType JvmStaticMethodCall descriptors + inferExtPrim fc returnType SetInstanceField descriptors = inferExtPrim fc returnType JvmStaticMethodCall descriptors inferExtPrim fc returnType JvmInstanceMethodCall descriptors = - inferExtPrim fc returnType JvmStaticMethodCall descriptors + inferExtPrim fc returnType JvmStaticMethodCall descriptors inferExtPrim fc returnType JvmStaticMethodCall [ret, NmApp _ _ [functionNamePrimVal], fargs, world] = inferExtPrim fc returnType JvmStaticMethodCall [ret, functionNamePrimVal, fargs, world] - inferExtPrim _ returnType JvmStaticMethodCall [ret, NmPrimVal fc (Str fn), fargs, world] + inferExtPrim _ returnType JvmStaticMethodCall [ret, _, fargs, _] = do args <- getFArgs fargs argTypes <- traverse tySpec (map fst args) methodReturnType <- tySpec ret traverse_ inferExtPrimArg $ zip (map snd args) argTypes pure $ if methodReturnType == IVoid then inferredObjectType else methodReturnType + inferExtPrim fc returnType JvmSuper [clazz, fargs, world] = do + rootMethodName <- getRootMethodName + if (endsWith (methodName rootMethodName) "$ltinit$gt") + then inferExtPrim fc returnType JvmStaticMethodCall [voidTypeExpr, NmErased fc, fargs, world] + else pure IUnknown inferExtPrim _ returnType NewArray [_, size, val, world] = do ignore $ inferExpr IInt size ignore $ inferExpr IUnknown val @@ -720,6 +783,25 @@ mutual ignore $ inferExpr IInt pos ignore $ inferExpr IUnknown val pure inferredObjectType + inferExtPrim _ returnType JvmNewArray [tyExpr, size, world] = do + ignore $ inferExpr IInt size + elemTy <- tySpec tyExpr + pure $ IArray elemTy + inferExtPrim _ returnType JvmSetArray [tyExpr, index, val, arr, world] = do + elemTy <- tySpec tyExpr + ignore $ inferExpr (IArray elemTy) arr + ignore $ inferExpr IInt index + ignore $ inferExpr elemTy val + pure inferredObjectType + inferExtPrim _ returnType JvmGetArray [tyExpr, index, arr, world] = do + elemTy <- tySpec tyExpr + ignore $ inferExpr (IArray elemTy) arr + ignore $ inferExpr IInt index + pure elemTy + inferExtPrim _ returnType JvmArrayLength [tyExpr, arr] = do + elemTy <- tySpec tyExpr + ignore $ inferExpr (IArray elemTy) arr + pure IInt inferExtPrim _ returnType NewIORef [_, val, world] = do ignore $ inferExpr IUnknown val pure refType @@ -733,10 +815,18 @@ mutual inferExtPrim _ returnType SysOS [] = pure inferredStringType inferExtPrim _ returnType SysCodegen [] = pure inferredStringType inferExtPrim _ returnType VoidElim _ = pure inferredObjectType - inferExtPrim _ returnType (Unknown name) _ = asmCrash $ "Can't compile unknown external directive " ++ show name + inferExtPrim _ returnType JvmClassLiteral [_] = pure $ IRef "java/lang/Class" Class [] + inferExtPrim _ returnType JvmInstanceOf [_, obj, _] = do + ignore $ inferExpr IUnknown obj + pure IBool + inferExtPrim _ returnType JvmRefEq [_, _, x, y] = inferBoolOp IUnknown x y + inferExtPrim fc returnType JavaLambda [functionType, javaInterfaceType, lambda] = do + ignore $ inferExpr IUnknown lambda + IFunction <$> getJavaLambdaType fc [functionType, javaInterfaceType, lambda] inferExtPrim _ returnType MakeFuture [_, action] = do ignore $ inferExpr delayedType action pure inferredForkJoinTaskType + inferExtPrim _ returnType (Unknown name) _ = asmCrash $ "Can't compile unknown external directive " ++ show name inferExtPrim fc _ prim args = Throw fc $ "Unsupported external function " ++ show prim ++ "(" ++ (show $ showNamedCExp 0 <$> args) ++ ")" @@ -756,7 +846,7 @@ mutual Pure lambdaBodyReturnType Pure $ if hasParameterValue then lambdaBodyReturnType - else getLambdaInterfaceType lambdaType lambdaBodyReturnType + else getLambdaInterfaceType lambdaType where createAndAddVariable : (String, InferredType) -> Asm () createAndAddVariable (name, ty) = do @@ -842,10 +932,10 @@ mutual inferSelfTailCallParameter : Map Int InferredType -> Map Int String -> (NamedCExp, Int) -> Asm () inferSelfTailCallParameter types argumentNameByIndices (arg, index) = do optTy <- LiftIo $ Map.get types index - let variableType = fromMaybe IUnknown optTy + let variableType = fromMaybe IUnknown $ nullableToMaybe optTy ty <- inferExpr variableType arg optName <- LiftIo $ Map.get {value=String} argumentNameByIndices index - maybe (Pure ()) (doAddVariableType ty) optName + maybe (Pure ()) (doAddVariableType ty) $ nullableToMaybe optName where doAddVariableType : InferredType -> String -> Asm () doAddVariableType ty name = do @@ -973,8 +1063,8 @@ showScopes n = do logAsm $ show scope when (n > 0) $ showScopes (n - 1) -tailRecLoopFunctionName : String -> Name -tailRecLoopFunctionName programName = +tailRecLoopFunctionName : Name +tailRecLoopFunctionName = NS (mkNamespace "io.github.mmhelloworld.idrisjvm.runtime.Runtime") (UN $ Basic "tailRec") delayNilArityExpr : FC -> (args: List Name) -> NamedCExp -> NamedCExp @@ -1007,7 +1097,7 @@ export optimize : String -> List (Name, FC, NamedDef) -> List (Name, FC, NamedDef) optimize programName allDefs = let tailRecOptimizedDefs = concatMap (optimizeTailRecursion programName) allDefs - tailCallOptimizedDefs = TailRec.functions (tailRecLoopFunctionName programName) tailRecOptimizedDefs + tailCallOptimizedDefs = TailRec.functions tailRecLoopFunctionName tailRecOptimizedDefs in toNameFcDef <$> tailCallOptimizedDefs export @@ -1022,8 +1112,8 @@ inferDef programName idrisName fc (MkNmFun args expr) = do let initialArgumentTypes = replicate arity inferredObjectType let inferredFunctionType = MkInferredFunctionType inferredObjectType initialArgumentTypes argumentTypesByName <- LiftIo $ Map.fromList $ zip argumentNames initialArgumentTypes - scopes <- LiftIo $ JList.new {a=Scope} - let function = MkFunction jname inferredFunctionType scopes 0 jvmClassAndMethodName emptyFunction + scopes <- LiftIo $ ArrayList.new {elemTy=Scope} + let function = MkFunction jname inferredFunctionType (subtyping scopes) 0 jvmClassAndMethodName emptyFunction setCurrentFunction function LiftIo $ AsmGlobalState.addFunction !getGlobalState jname function updateCurrentFunction $ { optimizedBody := expr } @@ -1058,10 +1148,10 @@ inferDef programName idrisName fc (MkNmFun args expr) = do go1 acc [] = pure acc go1 acc (arg :: args) = do optIndex <- Map.get {value=Int} argumentIndicesByName arg - ty <- case optIndex of + ty <- case nullableToMaybe optIndex of Just index => do optTy <- Map.get argumentTypesByIndex index - pure $ fromMaybe IUnknown optTy + pure $ fromMaybe IUnknown $ nullableToMaybe optTy Nothing => pure IUnknown go1 (ty :: acc) args @@ -1071,3 +1161,7 @@ inferDef programName idrisName fc def@(MkNmForeign foreignDescriptors argumentTy inferForeign programName idrisName fc foreignDescriptors argumentTypes returnType inferDef _ _ _ _ = Pure () + +export +asm : AsmState -> Asm a -> IO (a, AsmState) +asm = if shouldDebugAsm then mockRunAsm else runAsm diff --git a/src/Compiler/Jvm/Variable.idr b/src/Compiler/Jvm/Variable.idr index 08260d905..2a0bfb506 100644 --- a/src/Compiler/Jvm/Variable.idr +++ b/src/Compiler/Jvm/Variable.idr @@ -12,7 +12,7 @@ import Data.List getLocTy : Map Int InferredType -> Int -> IO InferredType getLocTy typesByIndex varIndex = do optTy <- Map.get typesByIndex varIndex - pure $ fromMaybe IUnknown optTy + pure $ fromMaybe IUnknown $ nullableToMaybe optTy getVarIndex : Map Int InferredType -> Int -> IO Int getVarIndex types index = go 0 0 where @@ -125,9 +125,9 @@ checkcast cname = Checkcast cname export asmCast : (sourceType: InferredType) -> (targetType: InferredType) -> Asm () -asmCast ty1@(IRef class1) ty2@(IRef class2) = when (class1 /= class2) (checkcast class2) +asmCast ty1@(IRef class1 _ _) ty2@(IRef class2 _ _) = when (class1 /= class2) (checkcast class2) -asmCast IUnknown ty@(IRef clazz) = checkcast clazz +asmCast IUnknown ty@(IRef clazz _ _) = checkcast clazz asmCast IBool IBool = Pure () asmCast IByte IByte = Pure () @@ -138,6 +138,7 @@ asmCast IInt IInt = Pure () asmCast ILong ILong = Pure () asmCast IFloat IFloat = Pure () asmCast IDouble IDouble = Pure () +asmCast (IArray _) (IArray _) = Pure () asmCast IBool IInt = boolToInt asmCast IInt IChar = I2c @@ -182,10 +183,12 @@ asmCast IFloat ty = boxFloat asmCast IDouble ty = boxDouble -asmCast (IRef _) arr@(IArray _) = Checkcast $ getJvmTypeDescriptor arr +asmCast (IRef _ _ _) arr@(IArray _) = Checkcast $ getJvmTypeDescriptor arr +asmCast (IArray _) (IRef clazz _ _) = Checkcast clazz +asmCast _ IVoid = Pure () asmCast IVoid IVoid = Pure () -asmCast IVoid (IRef _) = Aconstnull +asmCast IVoid (IRef _ _ _) = Aconstnull asmCast IVoid IUnknown = Aconstnull asmCast ty IUnknown = Pure () @@ -267,7 +270,8 @@ loadVar sourceLocTys ILong ILong var = opWithWordSize sourceLocTys Lload var loadVar sourceLocTys IFloat IFloat var = opWithWordSize sourceLocTys Fload var loadVar sourceLocTys IFloat IDouble var = opWithWordSize sourceLocTys (\var => do Fload var; F2d) var loadVar sourceLocTys IDouble IDouble var = opWithWordSize sourceLocTys Dload var -loadVar sourceLocTys IDouble IFloat var = opWithWordSize sourceLocTys (\var => do Dload var; D2f) var +loadVar sourceLocTys IDouble IFloat var = opWithWordSize sourceLocTys (\var => do Dload var; D2f) var +loadVar sourceLocTys ty1@(IArray _) ty2@(IArray _) var = opWithWordSize sourceLocTys Aload var loadVar sourceLocTys IBool ty var = loadAndBoxBool ty sourceLocTys var loadVar sourceLocTys IByte ty var = loadAndBoxByte ty sourceLocTys var @@ -295,24 +299,33 @@ loadVar sourceLocTys ty ILong var = let loadInstr = \index => do Aload index; objToLong in opWithWordSize sourceLocTys loadInstr var +loadVar sourceLocTys _ (IRef "java/math/BigInteger" _ _) var = + let loadInstr = \index => do + Aload index + InvokeMethod InvokeStatic conversionClass "toInteger" "(Ljava/lang/Object;)Ljava/math/BigInteger;" False + in opWithWordSize sourceLocTys loadInstr var + loadVar sourceLocTys ty IFloat var = let loadInstr = \index => do Aload index; objToFloat in opWithWordSize sourceLocTys loadInstr var loadVar sourceLocTys ty IDouble var = loadAndUnboxDouble ty sourceLocTys var -loadVar sourceLocTys IUnknown arr@(IArray _) var = +loadVar sourceLocTys _ arr@(IArray _) var = let loadInstr = \index => do Aload index; checkcast $ getJvmTypeDescriptor arr in opWithWordSize sourceLocTys loadInstr var -loadVar sourceLocTys IUnknown ty2@(IRef _) var = +loadVar sourceLocTys IUnknown ty2@(IRef _ _ _) var = let loadInstr = \index => do Aload index; asmCast IUnknown ty2 in opWithWordSize sourceLocTys loadInstr var -loadVar sourceLocTys (IRef _) IUnknown var = opWithWordSize sourceLocTys Aload var +loadVar sourceLocTys (IArray _) (IRef _ _ _) var = opWithWordSize sourceLocTys Aload var +loadVar sourceLocTys (IArray _) IUnknown var = opWithWordSize sourceLocTys Aload var + +loadVar sourceLocTys (IRef _ _ _) IUnknown var = opWithWordSize sourceLocTys Aload var loadVar sourceLocTys IUnknown IUnknown var = opWithWordSize sourceLocTys Aload var -loadVar sourceLocTys ty1@(IRef _) ty2@(IRef _) var = +loadVar sourceLocTys ty1@(IRef _ _ _) ty2@(IRef _ _ _) var = let loadInstr = \index => do Aload index; asmCast ty1 ty2 in opWithWordSize sourceLocTys loadInstr var @@ -335,6 +348,7 @@ storeVar IInt IInt var = do types <- getVariableTypes; opWithWordSize type storeVar ILong ILong var = do types <- getVariableTypes; opWithWordSize types Lstore var storeVar IFloat IFloat var = do types <- getVariableTypes; opWithWordSize types Fstore var storeVar IDouble IDouble var = do types <- getVariableTypes; opWithWordSize types Dstore var +storeVar (IArray _) (IArray _) var = do types <- getVariableTypes; opWithWordSize types Astore var storeVar IBool ty var = boxStore boxBool var storeVar IByte ty var = boxStore boxByte var @@ -364,7 +378,7 @@ storeVar ty IDouble var = storeVarWithWordSize (\index => do asmCast ty IDouble; storeVar ty arr@(IArray elemTy) var = storeVarWithWordSize (\index => do checkcast $ getJvmTypeDescriptor arr; Astore index) var -storeVar ty targetTy@(IRef _) var = do +storeVar ty targetTy@(IRef _ _ _) var = do types <- getVariableTypes asmCast ty targetTy opWithWordSize types Astore var diff --git a/src/Core/Core.idr b/src/Core/Core.idr index f66a331f4..80a605de5 100644 --- a/src/Core/Core.idr +++ b/src/Core/Core.idr @@ -892,7 +892,7 @@ wrapRef x onClose op pure o export -cond : List (Lazy Bool, Lazy a) -> a -> a +cond : List (Lazy Bool, Lazy a) -> Lazy a -> a cond [] def = def cond ((x, y) :: xs) def = if x then y else cond xs def diff --git a/src/TTImp/ProcessType.idr b/src/TTImp/ProcessType.idr index ac3273435..f7287e963 100644 --- a/src/TTImp/ProcessType.idr +++ b/src/TTImp/ProcessType.idr @@ -246,9 +246,8 @@ initDef fc n env ty (ForeignExport cs :: opts) where getConvention : String -> Core (String, String) getConvention c - = do let (lang ::: fname :: []) = split (== ':') c - | _ => throw (GenericMsg fc "Invalid calling convention") - pure (trim lang, trim fname) + = do let (lang ::: fname) = split (== ':') c + pure (trim lang, fastConcat $ intersperse ":" fname) initDef fc n env ty (_ :: opts) = initDef fc n env ty opts -- Find the inferrable argument positions in a type. This is useful for diff --git a/tests/jvm/jvm012/array.idr b/tests/jvm/jvm012/array.idr index 83fa302ac..67d3814e4 100644 --- a/tests/jvm/jvm012/array.idr +++ b/tests/jvm/jvm012/array.idr @@ -4,7 +4,7 @@ import System main : IO () main - = do x <- newArray 20 + = do x <- newArray {elem=String} 20 True <- writeArray x 10 "Hello" | False => do putStrLn "should success 1" exitFailure diff --git a/tests/jvm/jvm035/expected b/tests/jvm/jvm035/expected index 8828bb7f0..d66cea6a2 100644 --- a/tests/jvm/jvm035/expected +++ b/tests/jvm/jvm035/expected @@ -1,3 +1,3 @@ 1/1: Building Mod1 (Mod1.idr) hello world -build/exec/test_app/test.jar +build/exec/test_app/test/Main.class diff --git a/tests/jvm/jvm035/run b/tests/jvm/jvm035/run index b2190663e..af75a3a37 100755 --- a/tests/jvm/jvm035/run +++ b/tests/jvm/jvm035/run @@ -5,6 +5,6 @@ export IDRIS2_INC_CGS=jvm $1 --no-banner --no-color --console-width 0 -o test Mod2.idr < input ./build/exec/test -ls build/exec/test_app/test.jar +ls build/exec/test_app/test/Main.class rm -rf build diff --git a/tests/jvm/nat2fin/run b/tests/jvm/nat2fin/run index 0d941303c..3f7b81977 100644 --- a/tests/jvm/nat2fin/run +++ b/tests/jvm/nat2fin/run @@ -2,7 +2,7 @@ rm -rf build $1 --no-banner --no-color --quiet -o test Test.idr -javap -c -cp build/exec/test_app/test.jar test.Main > build/exec/test_app/test-decompiled.txt +javap -c -cp build/exec/test_app test.Main > build/exec/test_app/test-decompiled.txt $1 --no-banner --no-color --console-width 0 Check.idr < input