From 005c2bcc28599ef0ed73fa693be9a34187e3a7d7 Mon Sep 17 00:00:00 2001 From: Marimuthu Madasamy Date: Sun, 2 Jul 2023 21:07:48 -0400 Subject: [PATCH] Initial support for method and class export to Java #140 --- .github/workflows/install.yml | 2 +- .github/workflows/pre-release.yml | 2 +- .github/workflows/release.yml | 2 +- .../idrisjvm/assembler/AsmGlobalState.java | 3 +- .../idrisjvm/assembler/Assembler.java | 17 +- .../idrisjvm/assembler/IdrisName.java | 2 + idris2.ipkg | 2 +- idris2api.ipkg | 1 + src/Compiler/Jvm/Asm.idr | 300 +++++------ src/Compiler/Jvm/Codegen.idr | 107 ++-- src/Compiler/Jvm/Export.idr | 506 ++++++++++++++++++ src/Compiler/Jvm/Foreign.idr | 25 +- src/Compiler/Jvm/FunctionTree.idr | 5 +- src/Compiler/Jvm/Jname.idr | 3 - src/Compiler/Jvm/MockAsm.idr | 4 +- src/Compiler/Jvm/Optimizer.idr | 58 +- src/Compiler/Jvm/Variable.idr | 6 +- src/Core/Core.idr | 2 +- src/TTImp/ProcessType.idr | 5 +- 19 files changed, 780 insertions(+), 272 deletions(-) create mode 100644 src/Compiler/Jvm/Export.idr 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/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..82bf7fede 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,7 +6,6 @@ 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; @@ -150,7 +149,7 @@ 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(); 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..b02f8085f 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 @@ -1297,15 +1297,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/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/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/src/Compiler/Jvm/Asm.idr b/src/Compiler/Jvm/Asm.idr index 264929319..b897dea58 100644 --- a/src/Compiler/Jvm/Asm.idr +++ b/src/Compiler/Jvm/Asm.idr @@ -23,6 +23,9 @@ import Compiler.Jvm.ShowUtil import System import System.FFI +import Java.Lang +import Java.Util + public export data Assembler : Type where [external] @@ -51,17 +54,7 @@ data JInteger : Type where [external] data JDouble : Type where [external] data JLong : Type where [external] -namespace Collection - export - data CollectionNative : Type where [external] - - export - Collection : Type -> Type - Collection a = CollectionNative - -namespace Object - export - data Object : Type where [external] +namespace Object1 %foreign jvm' "java/lang/Object" ".toString" "java/lang/Object" "String" prim_toString : Object -> PrimIO String @@ -79,7 +72,7 @@ namespace Object 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 +81,89 @@ 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] - export - Iterable : Type -> Type - Iterable a = JIterable +public export +Inherits (Collection a) (Iterable a) where -namespace JList - export - data JListNative : Type where [external] +public export +Inherits (JList a) (Iterable a) where - export - JList : Type -> Type - JList a = JListNative +public export +Inherits (List a) (JList a) where + +namespace JList1 %foreign "jvm:(java/lang/Object java/util/ArrayList),java/util/ArrayList" - prim_newArrayList : PrimIO JListNative + prim_newArrayList : PrimIO (JList a) %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)) - - export - get : HasIO io => JList a -> Int -> io a - get list index = believe_me <$> (primIO $ prim_get (believe_me list) index) - - export - size : HasIO io => JList a -> io Int - size list = believe_me <$> (primIO $ prim_size (believe_me list)) + 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] - 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) @@ -201,35 +172,14 @@ namespace Entry value <- getValue {k=k} {v=v} entry pure (key, value) -namespace Map - export - data JMap : Type where [external] - - export - Map : Type -> Type -> Type - Map k v = JMap +namespace Map1 %foreign "jvm:(java/lang/Object java/util/TreeMap),java/util/TreeMap" - prim_newTreeMap : PrimIO JMap + prim_newTreeMap : PrimIO (Map key value) export newTreeMap : HasIO io => io (Map key value) - newTreeMap = believe_me <$> primIO prim_newTreeMap - - %foreign jvm' "java/util/Map" ".get" "i:java/util/Map java/lang/Object" "java/lang/Object" - prim_get : JMap -> Object -> PrimIO Object - - 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)) - - %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 - - 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 = primIO prim_newTreeMap goFromList : HasIO io => Map key value -> List (key, value) -> io () goFromList _ [] = pure () @@ -240,32 +190,32 @@ namespace Map export fromList : HasIO io => List (key, value) -> io (Map key value) fromList keyValues = do - m <- Map.newTreeMap {key=key} {value=value} + m <- Map1.newTreeMap {key=key} {value=value} goFromList m keyValues 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) + JList1.fromIterable entries export toList : HasIO io => Map k v -> io (List (k, v)) @@ -274,37 +224,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) + JList1.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) + JList1.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 @@ -466,15 +414,30 @@ record AsmState where assembler : Assembler public export -data Access = Private | Public | Static | Synthetic | Final +data Access = Private | Public | Protected | Static | Synthetic | Final | Interface | Abstract + +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 + _ == _ = 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" public export data FieldInstructionType = GetStatic | PutStatic | GetField | PutField @@ -498,7 +461,7 @@ Show InvocationType where show InvokeStatic = "InvokeStatic" show InvokeVirtual = "InvokeVirtual" -export +public export data ClassOpts = ComputeMaxs | ComputeFrames export @@ -531,6 +494,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,9 +505,11 @@ mutual | AnnArray (List AnnotationValue) | AnnAnnotation Annotation + public export AnnotationProperty : Type AnnotationProperty = (String, Asm.AnnotationValue) + public export data Annotation = MkAnnotation String (List AnnotationProperty) public export @@ -571,9 +537,9 @@ 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 () CreateLabel : String -> Asm () @@ -770,9 +736,9 @@ public export newAsmState : HasIO io => AsmGlobalState -> Assembler -> io AsmState newAsmState globalState assembler = do let defaultName = Jqualified "" "" - scopes <- JList.new {a=Scope} - lineNumberLabels <- Map.newTreeMap {key=Int} {value=String} - let function = MkFunction defaultName (MkInferredFunctionType IUnknown []) scopes + scopes <- ArrayList.new {elemTy=Scope} + lineNumberLabels <- Map1.newTreeMap {key=Int} {value=String} + 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 @@ -904,24 +870,25 @@ 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 <- JList1.nCopies {a=a} (index - size) nullValue + ignore $ JList1.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 + then ignore $ JList1.set scopes scopeIndex scope else do - fillNull scopeIndex scopes - JList.add scopes scopeIndex scope + fillNull {a=Scope} scopeIndex scopes + JList1.add scopes scopeIndex scope export getScope : Int -> Asm Scope @@ -950,7 +917,7 @@ newLabel = do hasLabelAtLine : Int -> Asm Bool hasLabelAtLine lineNumber = do state <- GetState - LiftIo $ Map.containsKey {value=String} (lineNumberLabels state) lineNumber + LiftIo $ Map1.containsKey {value=String} (lineNumberLabels state) lineNumber export addLineNumber : Int -> String -> Asm () @@ -968,7 +935,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,25 +990,25 @@ 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 + JList1.fromIterable jlist retrieveVariableIndicesByName : Int -> Asm (Map String Int) retrieveVariableIndicesByName scopeIndex = do - variableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + variableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} go variableIndices scopeIndex Pure variableIndices where @@ -1065,7 +1032,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 +1050,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 @@ -1092,7 +1059,7 @@ retrieveVariableTypeAtScope scopeIndex name = do export retrieveVariableTypesAtScope : Int -> Asm (Map Int InferredType) retrieveVariableTypesAtScope scopeIndex = do - typesByIndex <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} + typesByIndex <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} go typesByIndex !(retrieveVariables scopeIndex) Pure typesByIndex where @@ -1118,7 +1085,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 +1110,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 +1124,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 +1147,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 @@ -1248,12 +1215,16 @@ 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 export fieldInsTypeNum : FieldInstructionType -> Int @@ -1393,19 +1364,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 +1404,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 +1412,9 @@ 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 export toJFieldInitialValue : FieldInitialValue -> Object @@ -1554,6 +1527,27 @@ 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 +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 + +%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 = @@ -1630,12 +1624,12 @@ 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] + [assembler state, sum $ toJClassOpts <$> opts] runAsm state (CreateField accs sourceFileName className fieldName desc sig fieldInitialValue) = assemble state $ do let jaccs = sum $ accessNum <$> accs jvmInstance () "io/github/mmhelloworld/idrisjvm/assembler/Assembler.createField" diff --git a/src/Compiler/Jvm/Codegen.idr b/src/Compiler/Jvm/Codegen.idr index 59db7f795..6b8972ed2 100644 --- a/src/Compiler/Jvm/Codegen.idr +++ b/src/Compiler/Jvm/Codegen.idr @@ -3,43 +3,48 @@ 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 +import Java.Lang +import Java.Util + %default covering %hide System.FFI.runtimeClass @@ -51,7 +56,7 @@ addScopeLocalVariables scope = do let scopeIndex = index scope let (lineNumberStart, lineNumberEnd) = lineNumbers scope let (labelStart, labelEnd) = labels scope - nameAndIndices <- LiftIo $ Map.toList $ variableIndices scope + nameAndIndices <- LiftIo $ Map1.toList $ variableIndices scope go labelStart labelEnd nameAndIndices where go : String -> String -> List (String, Int) -> Asm () @@ -128,10 +133,10 @@ int64HashCode : Int64 -> Int bits64HashCode : Bits64 -> Int hashCode : TT.Constant -> Maybe Int -hashCode (BI value) = Just $ Object.hashCode value +hashCode (BI value) = Just $ Object1.hashCode value hashCode (I64 value) = Just $ int64HashCode value hashCode (B64 value) = Just $ bits64HashCode value -hashCode (Str value) = Just $ Object.hashCode value +hashCode (Str value) = Just $ Object1.hashCode value hashCode x = Nothing getHashCodeSwitchClass : FC -> InferredType -> Asm String @@ -1211,7 +1216,7 @@ mutual Dup let lambdaInterfaceType = getLambdaInterfaceType lambdaType lambdaBodyReturnType parameterType <- the (Asm (Maybe InferredType)) $ traverse getVariableType (jvmSimpleName <$> parameterName) - variableTypes <- LiftIo $ Map.values {key=Int} !(loadClosures declaringScope scope) + variableTypes <- LiftIo $ Map1.values {key=Int} !(loadClosures declaringScope scope) maybe (Pure ()) id parameterValueExpr let invokeDynamicDescriptor = getMethodDescriptor $ MkInferredFunctionType lambdaInterfaceType variableTypes let isExtracted = isJust parameterValueExpr @@ -1239,7 +1244,7 @@ mutual maybe indy (const staticCall) parameterValueExpr when isTailCall $ if isExtracted then asmReturn lambdaReturnType else asmReturn lambdaInterfaceType let oldLineNumberLabels = lineNumberLabels !GetState - newLineNumberLabels <- LiftIo $ Map.newTreeMap {key=Int} {value=String} + newLineNumberLabels <- LiftIo $ Map1.newTreeMap {key=Int} {value=String} updateState $ { lineNumberLabels := newLineNumberLabels } className <- getClassName let accessModifiers = if isExtracted then [Public, Static] else [Public, Static, Synthetic] @@ -1284,7 +1289,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 @@ -1292,14 +1297,14 @@ mutual loadClosures declaringScope currentScope = case parentIndex currentScope of Just parentScopeIndex => do parentScope <- getScope parentScopeIndex - variableNames <- LiftIo $ Map.keys {value=Int} $ variableIndices parentScope + variableNames <- LiftIo $ Map1.keys {value=Int} $ variableIndices parentScope variableNameAndIndex <- traverse getVariableNameAndIndex variableNames typesByIndex <- getIndexAndType variableNameAndIndex declaringScopeVariableTypes <- getVariableTypesAtScope (index declaringScope) - indices <- LiftIo $ Map.keys {value=Entry InferredType InferredType} typesByIndex + indices <- LiftIo $ Map1.keys {value=Entry InferredType InferredType} typesByIndex loadVariables declaringScopeVariableTypes typesByIndex indices - LiftIo $ Map.getValue2 {k=Int} {v1=InferredType} {v2=InferredType} typesByIndex - Nothing => LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} + LiftIo $ Map1.getValue2 {k=Int} {v1=InferredType} {v2=InferredType} typesByIndex + Nothing => LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} where getVariableNameAndIndex : String -> Asm (String, Int) getVariableNameAndIndex name = do @@ -1308,7 +1313,7 @@ mutual getIndexAndType : List (String, Int) -> Asm (Map Int (Entry InferredType InferredType)) getIndexAndType nameAndIndices = do - typesByIndexMap <- LiftIo $ Map.newTreeMap {key=Int} {value=Entry InferredType InferredType} + typesByIndexMap <- LiftIo $ Map1.newTreeMap {key=Int} {value=Entry InferredType InferredType} go typesByIndexMap Pure typesByIndexMap where @@ -1471,7 +1476,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 +1491,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 @@ -1723,7 +1728,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} + lineNumberLabels <- LiftIo $ Map1.newTreeMap {key=Int} {value=String} updateState $ { scopeCounter := 0, currentScopeIndex := 0, @@ -1784,25 +1789,11 @@ 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} + namesByClassName <- Map1.newTreeMap {key=String} {value=List Name} go1 namesByClassName names - Map.values {key=String} namesByClassName + Map1.values {key=String} namesByClassName where go1 : Map String (List Name) -> List Name -> IO () go1 namesByClassName values = go2 values where @@ -1811,29 +1802,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 () @@ -1859,7 +1843,9 @@ isForeignDef _ = False ||| 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) @@ -1868,17 +1854,18 @@ compileToJvmBytecode c outputDirectory outputFile term = do let allDefs = (mainFunctionName, emptyFC, MkNmFun [] idrisMainBody) :: ndefs let nameFcDefs = optimize programName allDefs ++ filter isForeignDef allDefs let nameStrFcDefs = getNameStrFcDef <$> nameFcDefs - fcAndDefinitionsByName <- coreLift $ Map.fromList nameStrFcDefs + fcAndDefinitionsByName <- coreLift $ Map1.fromList nameStrFcDefs let nameStrDefs = getNameStrDef <$> nameStrFcDefs - definitionsByName <- coreLift $ Map.fromList nameStrDefs + definitionsByName <- coreLift $ Map1.fromList nameStrDefs globalState <- coreLift $ newAsmGlobalState programName - let names = groupByClassName programName . traverseDepthFirst $ - buildFunctionTreeMain mainFunctionName definitionsByName + 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) names + 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..a9f2c157d --- /dev/null +++ b/src/Compiler/Jvm/Export.idr @@ -0,0 +1,506 @@ +module Compiler.Jvm.Export + +import Compiler.Common +import Compiler.CompileExpr +import Compiler.Inline +import Compiler.NoMangle +import Compiler.Jvm.Asm +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.Options +import Core.TT +import Data.List +import Data.List1 +import Data.Maybe +import Data.String +import Java.Lang +import Java.Util +import Language.JSON +import Libraries.Data.SortedMap +import Libraries.Utils.Path + +import System.FFI + +record ExportArgument where + constructor MkExportArgument + type: InferredType + annotations: List Annotation + +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) + +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) + +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 => asmCrash ("Missing JVM type in foreign export for " ++ show functionName) + loadVar typesByIndex jvmType idrisType varIndex + go (varIndex + 1) rest + +record ClassExport where + constructor MkClassExport + name: String + idrisName: Name + extends: String + implements: List String + modifiers: List Access + annotations: List Annotation + +record MethodExport where + constructor MkMethodExport + name: String + idrisName: Name + type: InferredFunctionType + encloser: ClassExport + modifiers: List Access + annotations: List Annotation + parameterAnnotations: List (List Annotation) + +record FieldExport where + constructor MkFieldExport + name: String + idrisName: Name + type: InferredType + encloser: ClassExport + modifiers: List Access + annotations: List Annotation + +data ExportDescriptor : Type where + MkFieldExportDescriptor : FieldExport -> ExportDescriptor + MkMethodExportDescriptor : MethodExport -> ExportDescriptor + MkClassExportDescriptor : ClassExport -> ExportDescriptor + MkImportDescriptor : Name -> SortedMap String String -> ExportDescriptor + +parseModifier : String -> Maybe Access +parseModifier "public" = Just Public +parseModifier "private" = Just Private +parseModifier "static" = Just Static +parseModifier "synthetic" = Just Synthetic +parseModifier "final" = Just Final +parseModifier "interface" = Just Interface +parseModifier "abstract" = Just Abstract +parseModifier invalid = Nothing + +parseString : String -> JSON -> Asm String +parseString _ (JString value) = Pure value +parseString errorMessage _ = asmCrash errorMessage + +parseClassExport : Name -> (nameParts : List String) -> {auto 0 nonEmpty : NonEmpty nameParts} -> + SortedMap String JSON -> List Annotation -> Asm ClassExport +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) + Pure $ MkClassExport (last parts) name extends implements (mapMaybe parseModifier parts) annotations + +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) + +parseMethodExport : Name -> (javaName: String) -> (nameParts: List String) -> {auto 0 nonEmpty : NonEmpty nameParts} -> + 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 + Just jvmReturnTypeString <- + traverse (parseString ("Invalid return type for function " ++ javaName)) $ lookup "returnType" descriptor + | Nothing => asmCrash ("Missing return type for " ++ javaName) + let jvmReturnType = parse jvmReturnTypeString + let functionType = MkInferredFunctionType jvmReturnType jvmArgumentTypes + let modifiers = mapMaybe parseModifier parts + 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 + encloser <- case words enclosingTypeName of + [] => asmCrash ("Unable to determine enclosing type for " ++ javaName) + enclosingTypeParts@(_ :: _) => + parseClassExport idrisName enclosingTypeParts SortedMap.empty [] + Pure $ MkMethodExport (last parts) idrisName functionType encloser adjustedModifiers annotations + adjustedParameterAnnotations + +parseFieldExport : Name -> (nameParts: List String) -> {auto 0 nonEmpty : NonEmpty nameParts} -> + SortedMap String JSON -> List Annotation -> Asm FieldExport +parseFieldExport name parts descriptor annotations = do + let modifiers = mapMaybe parseModifier parts + Just enclosingTypeName <- + traverse (parseString ("Invalid 'enclosingType' for " ++ show name)) $ lookup "enclosingType" descriptor + | Nothing => asmCrash ("Missing 'enclosingType' for " ++ show name) + encloser <- case words enclosingTypeName of + [] => asmCrash ("Missing enclosing type for " ++ show name) + enclosingTypeParts@(_ :: _) => + parseClassExport name enclosingTypeParts SortedMap.empty [] + Just typeString <- + traverse (parseString ("Invalid type for field " ++ show name)) $ lookup "type" descriptor + | Nothing => asmCrash ("Missing type for " ++ show name) + Pure $ MkFieldExport (last parts) name (parse typeString) encloser modifiers annotations + +parseObjectExportDescriptor : Name -> String -> List (String, JSON) -> Asm 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, + MkMethodExportDescriptor <$> parseMethodExport idrisName javaName parts descriptor annotations), + (isJust $ lookup "type" descriptor, + MkFieldExportDescriptor <$> parseFieldExport idrisName parts descriptor annotations) + ] + (MkClassExportDescriptor <$> parseClassExport idrisName parts descriptor annotations) + +parseJsonExport : Name -> String -> Asm 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 ++ " with signature " ++ + signature ++ " 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 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 "java/lang/Object" [] [Public] [] + Pure $ MkMethodExport javaName functionName functionType 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 functionType = MkInferredFunctionType (parse (last types)) (parse <$> (init types)) + let encloser = MkClassExport className functionName "java/lang/Object" [] [Public] [] + Pure $ MkMethodExport javaName functionName functionType 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 "java/lang/Object" [] [Public] [] + Pure $ MkFieldExport javaName functionName (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 "java/lang/Object" [] [Public] [] + Pure $ MkFieldExport javaName functionName (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 ExportDescriptor +parseExportDescriptor functionName descriptor = cond + [ + ("{" `isInfixOf` descriptor, parseJsonExport functionName descriptor), + ("." `isInfixOf` descriptor, MkMethodExportDescriptor <$> parseMethodSimpleExport functionName descriptor), + ("#" `isInfixOf` descriptor, MkFieldExportDescriptor <$> parseFieldSimpleExport functionName descriptor) + ] + (parseImports functionName descriptor) + +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) + +exportFunction : MethodExport -> Asm () +exportFunction (MkMethodExport jvmFunctionName idrisName type 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 $ Map1.fromList $ zip [0 .. (arityInt - 1)] jvmArgumentTypes + let isInstance = not $ elem Static modifiers + jvmArgumentTypesForSignature <- adjustArgumentsForInstanceMember idrisName isInstance jvmArgumentTypes + let functionType = getMethodDescriptor (MkInferredFunctionType jvmReturnType jvmArgumentTypesForSignature) + CreateMethod modifiers fileName jvmClassName jvmFunctionName functionType Nothing Nothing annotations + parameterAnnotations + MethodCodeStart + let jvmIdrisName = jvmName idrisName + let idrisArgumentTypes = replicate arity inferredObjectType + let idrisFunctionType = MkInferredFunctionType inferredObjectType idrisArgumentTypes + loadArguments jvmArgumentTypesByIndex idrisName arityInt (parameterTypes idrisFunctionType) + let idrisMethodDescriptor = getMethodDescriptor idrisFunctionType + let qualifiedJvmIdrisName = getIdrisFunctionName !getProgramName (className jvmIdrisName) (methodName jvmIdrisName) + InvokeMethod InvokeStatic + (className qualifiedJvmIdrisName) (methodName qualifiedJvmIdrisName) idrisMethodDescriptor False + when (jvmReturnType == IVoid) $ + InvokeMethod InvokeStatic "main/PrimIO" "unsafePerformIO" "(Ljava/lang/Object;)Ljava/lang/Object;" False + asmCast (returnType idrisFunctionType) jvmReturnType + asmReturn jvmReturnType + MaxStackAndLocal (-1) (-1) + MethodCodeEnd + +exportField : FieldExport -> Asm () +exportField _ = Pure () + +exportClass : ClassExport -> Asm () +exportClass (MkClassExport name idrisName extends implements modifiers annotations) = do + CreateClass [ComputeMaxs, ComputeFrames] + ClassCodeStart 52 modifiers name Nothing extends implements annotations + +exportMemberIo : AsmGlobalState -> ExportDescriptor -> IO () +exportMemberIo globalState (MkMethodExportDescriptor desc) = do + asmState <- createAsmState globalState desc.idrisName + ignore $ asm asmState $ exportFunction desc +exportMemberIo globalState (MkFieldExportDescriptor desc) = do + asmState <- createAsmState globalState desc.idrisName + ignore $ asm asmState $ exportField desc +exportMemberIo globalState (MkClassExportDescriptor desc) = do + asmState <- createAsmState globalState desc.idrisName + ignore $ asm asmState $ exportClass desc +exportMemberIo _ _ = pure () + +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) = maybe ref IRef $ SortedMap.lookup type imports +substituteType imports ref@(IArray (IRef type)) = maybe ref (IArray . IRef) $ 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) + +substituteClassExport : SortedMap Namespace (SortedMap String String) -> ClassExport -> ClassExport +substituteClassExport functionImports desc = case SortedMap.lookup (getNamespace desc.idrisName) functionImports of + Nothing => desc + Just imports => + let + updatedName = substituteTypeName imports desc.name + updatedExtends = substituteTypeName imports desc.extends + updatedImplements = substituteTypeName 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 SortedMap.lookup (getNamespace desc.idrisName) functionImports 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 updatedEncloser desc.modifiers + updatedAnnotations updatedParameterAnnotations +substituteImport functionImports exportDesc@(MkFieldExportDescriptor desc) = + case SortedMap.lookup (getNamespace desc.idrisName) functionImports 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 desc.idrisName 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 + +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 + (exportDescriptor, _) <- asm asmState (parseExportDescriptor idrisName descriptor) + case exportDescriptor of + MkImportDescriptor name currentImports => + let newImports = SortedMap.merge imports (SortedMap.singleton (getNamespace name) currentImports) + in go (newImports, descriptors) rest + _ => go (imports, exportDescriptor :: descriptors) rest + +export +exportDefs : AsmGlobalState -> List (Name, String) -> IO () +exportDefs globalState nameAndDescriptors = do + descriptors <- parseExportDescriptors globalState nameAndDescriptors + traverse_ (exportMemberIo globalState) descriptors + +export +getExport : NoMangleMap -> Name -> Maybe (Name, String) +getExport noMangleMap name = (\descriptor => (name, descriptor)) <$> isNoMangle noMangleMap name diff --git a/src/Compiler/Jvm/Foreign.idr b/src/Compiler/Jvm/Foreign.idr index feb64a98c..333b1fe56 100644 --- a/src/Compiler/Jvm/Foreign.idr +++ b/src/Compiler/Jvm/Foreign.idr @@ -22,6 +22,9 @@ import Compiler.Jvm.Asm import Compiler.Jvm.ExtPrim import Compiler.Jvm.ShowUtil +import Java.Lang +import Java.Util + namespace ForeignType public export data ForeignType @@ -170,8 +173,8 @@ findJvmDescriptor fc name descriptors = case parseCC ["jvm"] descriptors of export 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] +getArgumentIndices 0 _ = Map1.newTreeMap {key=String} {value=Int} +getArgumentIndices argIndex args = Map1.fromList $ zip args [0 .. argIndex - 1] getPrimMethodName : String -> String getPrimMethodName "" = "prim__jvmStatic" @@ -236,7 +239,7 @@ 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 externalFunctionBody = NmExtPrim fc (NS (mkNamespace "") $ UN $ Basic $ getPrimMethodName foreignFunctionName) [ NmCon fc (UN $ Basic $ createExtPrimTypeSpec jvmReturnType) DATACON Nothing [], @@ -244,15 +247,15 @@ inferForeign programName idrisName fc foreignDescriptors argumentTypes returnTyp 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 argumentTypesByIndex <- LiftIo $ if isNilArity - then Map.newTreeMap {key=Int} {value=InferredType} - else Map.fromList $ zip [0 .. arity - 1] parameterTypes - argumentTypesByName <- LiftIo $ Map.fromList $ zip argumentNames parameterTypes + then Map1.newTreeMap {key=Int} {value=InferredType} + else Map1.fromList $ zip [0 .. arity - 1] parameterTypes + argumentTypesByName <- LiftIo $ Map1.fromList $ zip argumentNames parameterTypes argIndices <- LiftIo $ getArgumentIndices arity argumentNames let functionScope = MkScope scopeIndex Nothing argumentTypesByName argumentTypesByIndex argIndices argIndices methodReturnType arity (0, 0) ("", "") [] @@ -260,10 +263,10 @@ inferForeign programName idrisName fc foreignDescriptors argumentTypes returnTyp when isNilArity $ do let parentScopeIndex = scopeIndex scopeIndex <- newScopeIndex - variableTypes <- LiftIo $ Map.newTreeMap {key=String} {value=InferredType} - allVariableTypes <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} - variableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} - allVariableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + variableTypes <- LiftIo $ Map1.newTreeMap {key=String} {value=InferredType} + allVariableTypes <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} + variableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} + allVariableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} let delayLambdaScope = MkScope scopeIndex (Just parentScopeIndex) variableTypes allVariableTypes variableIndices allVariableIndices IUnknown 0 (0, 0) ("", "") [] diff --git a/src/Compiler/Jvm/FunctionTree.idr b/src/Compiler/Jvm/FunctionTree.idr index c602d6a60..738d4893f 100644 --- a/src/Compiler/Jvm/FunctionTree.idr +++ b/src/Compiler/Jvm/FunctionTree.idr @@ -14,6 +14,9 @@ import Compiler.Jvm.Tree import Libraries.Data.SortedSet import Data.Vect +import Java.Lang +import Java.Util + parameters (defs: Map String NamedDef) mutual buildFunctionTreeConAlt : List (Tree Name) -> SortedSet Name -> List NamedConAlt -> (SortedSet Name, List (Tree Name)) @@ -83,7 +86,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/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..5223353d1 100644 --- a/src/Compiler/Jvm/MockAsm.idr +++ b/src/Compiler/Jvm/MockAsm.idr @@ -18,6 +18,8 @@ import Compiler.Jvm.InferredType import Compiler.Jvm.Jname import Compiler.Jvm.ShowUtil +import Java.Lang + %foreign "jvm:toString(java/lang/Object java/lang/String),java/util/Objects" prim_objectToString : AnyPtr -> PrimIO String @@ -70,7 +72,7 @@ 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] diff --git a/src/Compiler/Jvm/Optimizer.idr b/src/Compiler/Jvm/Optimizer.idr index b87f6a310..a612bd6c8 100644 --- a/src/Compiler/Jvm/Optimizer.idr +++ b/src/Compiler/Jvm/Optimizer.idr @@ -24,8 +24,12 @@ import Compiler.Jvm.ExtPrim import Compiler.Jvm.Foreign import Compiler.Jvm.InferredType import Compiler.Jvm.Jname +import Compiler.Jvm.MockAsm import Compiler.Jvm.ShowUtil +import Java.Lang +import Java.Util + %hide Core.Context.Context.Constructor.arity isBoolTySpec : String -> Name -> Bool @@ -378,10 +382,10 @@ enterInferenceScope lineNumberStart lineNumberEnd = do parentScopeIndex <- getCurrentScopeIndex scopeIndex <- newScopeIndex parentScope <- getScope parentScopeIndex - variableTypes <- LiftIo $ Map.newTreeMap {key=String} {value=InferredType} - allVariableTypes <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} - variableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} - allVariableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + variableTypes <- LiftIo $ Map1.newTreeMap {key=String} {value=InferredType} + allVariableTypes <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} + variableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} + allVariableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} let newScope = MkScope scopeIndex (Just parentScopeIndex) variableTypes allVariableTypes variableIndices allVariableIndices IUnknown (nextVariableIndex parentScope) (lineNumberStart, lineNumberEnd) ("", "") [] @@ -391,10 +395,10 @@ enterInferenceScope lineNumberStart lineNumberEnd = do createLambdaClosureScope : Int -> Int -> List String -> Scope -> Asm Scope createLambdaClosureScope scopeIndex childScopeIndex closureVariables parentScope = do - lambdaClosureVariableIndices <- LiftIo $ Map.fromList $ getLambdaClosureVariableIndices [] 0 closureVariables - variableTypes <- LiftIo $ Map.newTreeMap {key=String} {value=InferredType} - allVariableTypes <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} - allVariableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + lambdaClosureVariableIndices <- LiftIo $ Map1.fromList $ getLambdaClosureVariableIndices [] 0 closureVariables + variableTypes <- LiftIo $ Map1.newTreeMap {key=String} {value=InferredType} + allVariableTypes <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} + allVariableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} Pure $ MkScope scopeIndex (Just $ index parentScope) variableTypes allVariableTypes lambdaClosureVariableIndices allVariableIndices IUnknown (cast $ length closureVariables) (lineNumbers parentScope) ("", "") [childScopeIndex] @@ -411,10 +415,10 @@ enterInferenceLambdaScope lineNumberStart lineNumberEnd parameterName expr = do let boundVariables = maybe SortedSet.empty (flip SortedSet.insert SortedSet.empty . jvmSimpleName) parameterName let freeVariables = getFreeVariables boundVariables expr let usedVariables = filter (flip SortedSet.contains freeVariables) !(retrieveVariables parentScopeIndex) - variableTypes <- LiftIo $ Map.newTreeMap {key=String} {value=InferredType} - allVariableTypes <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} - variableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} - allVariableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + variableTypes <- LiftIo $ Map1.newTreeMap {key=String} {value=InferredType} + allVariableTypes <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} + variableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} + allVariableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} newScope <- case usedVariables of nonEmptyUsedVariables@(_ :: _) => do parentScope <- getScope parentScopeIndex @@ -842,10 +846,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 @@ -863,7 +867,7 @@ mutual [] => Pure exprTy args@(_ :: argsTail) => do types <- retrieveVariableTypesAtScope !getCurrentScopeIndex - argumentNameByIndices <- LiftIo $ Map.transpose $ variableIndices !(getScope 0) + argumentNameByIndices <- LiftIo $ Map1.transpose $ variableIndices !(getScope 0) traverse_ (inferSelfTailCallParameter types argumentNameByIndices) $ zip args [0 .. the Int $ cast $ length argsTail] Pure exprTy @@ -973,8 +977,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 +1011,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 @@ -1021,9 +1025,9 @@ inferDef programName idrisName fc (MkNmFun args expr) = do argIndices <- LiftIo $ getArgumentIndices arityInt argumentNames 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 + argumentTypesByName <- LiftIo $ Map1.fromList $ zip argumentNames initialArgumentTypes + 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 } @@ -1031,8 +1035,8 @@ inferDef programName idrisName fc (MkNmFun args expr) = do resetScope scopeIndex <- newScopeIndex let (_, lineStart, lineEnd) = getSourceLocation expr - allVariableTypes <- LiftIo $ Map.newTreeMap {key=Int} {value=InferredType} - allVariableIndices <- LiftIo $ Map.newTreeMap {key=String} {value=Int} + allVariableTypes <- LiftIo $ Map1.newTreeMap {key=Int} {value=InferredType} + allVariableIndices <- LiftIo $ Map1.newTreeMap {key=String} {value=Int} let functionScope = MkScope scopeIndex Nothing argumentTypesByName allVariableTypes argIndices allVariableIndices IUnknown arityInt (lineStart, lineEnd) ("", "") [] @@ -1058,10 +1062,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 +1075,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..8d8eee325 100644 --- a/src/Compiler/Jvm/Variable.idr +++ b/src/Compiler/Jvm/Variable.idr @@ -9,10 +9,13 @@ import Compiler.Jvm.InferredType import Data.Maybe import Data.List +import Java.Lang +import Java.Util + 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 @@ -184,6 +187,7 @@ asmCast IDouble ty = boxDouble asmCast (IRef _) arr@(IArray _) = Checkcast $ getJvmTypeDescriptor arr +asmCast _ IVoid = Pure () asmCast IVoid IVoid = Pure () asmCast IVoid (IRef _) = Aconstnull asmCast IVoid IUnknown = Aconstnull 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