issue-15 support Java arrays (#58)

Author: mmhelloworld

idris-jvm-codegen-launcher/pom.xml

@@ -10,6 +10,7 @@
     <modelVersion>4.0.0</modelVersion>
 
     <artifactId>idris-jvm-codegen-launcher</artifactId>
+    <name>Idris JVM Codegen Launcher</name>
 
     <properties>
         <assemble.dir.name>dist</assemble.dir.name>

idris-jvm-core/pom.xml

@@ -10,6 +10,7 @@
     <modelVersion>4.0.0</modelVersion>
 
     <artifactId>idris-jvm-core</artifactId>
+    <name>Idris JVM Core</name>
 
     <properties>
         <idris.srcdir>${project.basedir}/src/main/idris</idris.srcdir>

idris-jvm-core/src/main/idris/IdrisJvm/Core/Asm.idr

@@ -16,7 +16,7 @@ mutual
 
   data ReferenceTypeDescriptor = ClassDesc ClassName
                                | InterfaceDesc ClassName
-                               | ArrayDesc ReferenceTypeDescriptor
+                               | ArrayDesc FieldTypeDescriptor
                                | IdrisExportDesc ClassName
                                | NullableStrDesc
                                | NullableRefDesc ClassName
@@ -114,7 +114,7 @@ mutual
   Show ReferenceTypeDescriptor where
     show (ClassDesc className) = "ClassDesc " ++ show className
     show (InterfaceDesc className) = "InterfaceDesc " ++ show className
-    show (ArrayDesc referenceTypeDescriptor) = "ArrayDesc " ++ show referenceTypeDescriptor
+    show (ArrayDesc tyDesc) = "ArrayDesc " ++ show tyDesc
     show (IdrisExportDesc className) = "IdrisExportDesc " ++ show className
     show NullableStrDesc = "NullableStrDesc"
     show (NullableRefDesc className) = "NullableRefDesc" ++ show className
@@ -146,34 +146,34 @@ Eq JMethodName where
 Show JMethodName where
   show (MkJMethodName cname mname) = cname ++ "#" ++ mname
 
-
-asmRefTyDesc : ReferenceTypeDescriptor -> String
-asmRefTyDesc (ClassDesc c)       = "L" ++ c ++ ";"
-asmRefTyDesc (IdrisExportDesc c) = "L" ++ c ++ ";"
-asmRefTyDesc (InterfaceDesc c)   = "L" ++ c ++ ";"
-asmRefTyDesc (NullableRefDesc c) = "L" ++ c ++ ";"
-asmRefTyDesc NullableStrDesc     = "Ljava/lang/String;"
-asmRefTyDesc (ArrayDesc refTy)   = "[" ++ asmRefTyDesc refTy
-
-refTyClassName : ReferenceTypeDescriptor -> ClassName
-refTyClassName (ClassDesc c)       = c
-refTyClassName (InterfaceDesc c)   = c
-refTyClassName (IdrisExportDesc c) = c
-refTyClassName (NullableRefDesc c) = c
-refTyClassName NullableStrDesc     = "java/lang/String"
-refTyClassName arr@(ArrayDesc _)   = asmRefTyDesc arr
-
-asmFieldTypeDesc : FieldTypeDescriptor -> String
-asmFieldTypeDesc FieldTyDescByte          = "B"
-asmFieldTypeDesc FieldTyDescChar          = "C"
-asmFieldTypeDesc FieldTyDescShort         = "S"
-asmFieldTypeDesc FieldTyDescBoolean       = "Z"
-asmFieldTypeDesc FieldTyDescArray         = "["
-asmFieldTypeDesc FieldTyDescDouble        = "D"
-asmFieldTypeDesc FieldTyDescFloat         = "F"
-asmFieldTypeDesc FieldTyDescInt           = "I"
-asmFieldTypeDesc FieldTyDescLong          = "J"
-asmFieldTypeDesc (FieldTyDescReference f) = asmRefTyDesc f
+mutual
+    asmRefTyDesc : ReferenceTypeDescriptor -> String
+    asmRefTyDesc (ClassDesc c)       = "L" ++ c ++ ";"
+    asmRefTyDesc (IdrisExportDesc c) = "L" ++ c ++ ";"
+    asmRefTyDesc (InterfaceDesc c)   = "L" ++ c ++ ";"
+    asmRefTyDesc (NullableRefDesc c) = "L" ++ c ++ ";"
+    asmRefTyDesc NullableStrDesc     = "Ljava/lang/String;"
+    asmRefTyDesc (ArrayDesc ty)   = "[" ++ asmFieldTypeDesc ty
+
+    refTyClassName : ReferenceTypeDescriptor -> ClassName
+    refTyClassName (ClassDesc c)       = c
+    refTyClassName (InterfaceDesc c)   = c
+    refTyClassName (IdrisExportDesc c) = c
+    refTyClassName (NullableRefDesc c) = c
+    refTyClassName NullableStrDesc     = "java/lang/String"
+    refTyClassName arr@(ArrayDesc _)   = asmRefTyDesc arr
+
+    asmFieldTypeDesc : FieldTypeDescriptor -> String
+    asmFieldTypeDesc FieldTyDescByte          = "B"
+    asmFieldTypeDesc FieldTyDescChar          = "C"
+    asmFieldTypeDesc FieldTyDescShort         = "S"
+    asmFieldTypeDesc FieldTyDescBoolean       = "Z"
+    asmFieldTypeDesc FieldTyDescArray         = "["
+    asmFieldTypeDesc FieldTyDescDouble        = "D"
+    asmFieldTypeDesc FieldTyDescFloat         = "F"
+    asmFieldTypeDesc FieldTyDescInt           = "I"
+    asmFieldTypeDesc FieldTyDescLong          = "J"
+    asmFieldTypeDesc (FieldTyDescReference f) = asmRefTyDesc f
 
 asmTypeDesc : TypeDescriptor -> String
 asmTypeDesc (FieldDescriptor t) = asmFieldTypeDesc t
@@ -190,8 +190,23 @@ data Asm : Type -> Type where
     Aconstnull : Asm ()
     Aload : Int -> Asm ()
     Anewarray : Descriptor -> Asm ()
-    Astore : Int -> Asm ()
+
+    Anewbooleanarray : Asm ()
+    Anewbytearray : Asm ()
+    Anewchararray : Asm ()
+    Anewshortarray : Asm ()
+    Anewintarray : Asm ()
+    Anewlongarray : Asm ()
+    Anewfloatarray : Asm ()
+    Anewdoublearray : Asm ()
+
+    Arraylength : Asm ()
     Areturn : Asm ()
+    Astore : Int -> Asm ()
+    Baload : Asm ()
+    Bastore : Asm ()
+    Caload : Asm ()
+    Castore : Asm ()
     Checkcast : Descriptor -> Asm ()
     ClassCodeStart : Int -> Access -> ClassName -> (Maybe Signature) -> ClassName -> List ClassName -> List Annotation -> Asm ()
     ClassCodeEnd : String -> Asm ()
@@ -201,6 +216,8 @@ data Asm : Type -> Type where
     CreateMethod : List Access -> ClassName -> MethodName -> Descriptor -> Maybe Signature ->
                    Maybe (List Exception) -> List Annotation -> List (List Annotation) -> Asm ()
     Dadd : Asm ()
+    Daload : Asm ()
+    Dastore : Asm ()
     Ddiv : Asm ()
     Dload : Int -> Asm ()
     Dmul : Asm ()
@@ -210,6 +227,8 @@ data Asm : Type -> Type where
     Dup : Asm ()
     Error : String -> Asm ()
     F2d : Asm ()
+    Faload : Asm ()
+    Fastore : Asm ()
     Field : FieldInsType -> ClassName -> FieldName -> Descriptor -> Asm ()
     FieldEnd : Asm ()
     Fload : Int -> Asm ()
@@ -224,7 +243,9 @@ data Asm : Type -> Type where
     I2c : Asm ()
     I2l : Asm ()
     Iadd : Asm ()
+    Iaload : Asm ()
     Iand : Asm ()
+    Iastore : Asm ()
     Ior : Asm ()
     Ixor : Asm ()
     Icompl : Asm ()
@@ -249,7 +270,9 @@ data Asm : Type -> Type where
     L2i : Asm ()
     LabelStart : Label -> Asm ()
     Ladd : Asm ()
+    Laload : Asm ()
     Land : Asm ()
+    Lastore : Asm ()
     Lor : Asm ()
     Lxor : Asm ()
     Lcompl : Asm ()
@@ -267,11 +290,14 @@ data Asm : Type -> Type where
     MaxStackAndLocal : Int -> Int -> Asm ()
     MethodCodeStart : Asm ()
     MethodCodeEnd : Asm ()
+    Multianewarray : Descriptor -> Nat -> Asm ()
     New : ClassName -> Asm ()
     InstanceOf : ClassName -> Asm ()
     Pop : Asm ()
     Pop2 : Asm ()
     Return : Asm ()
+    Saload : Asm ()
+    Sastore : Asm ()
     ShouldDescribeFrame : Asm Bool
     SourceInfo : SourceFileName -> Asm ()
     Subroutine : Asm () -> Asm ()
@@ -296,4 +322,4 @@ Applicative Asm where
 
   (<*>) f a = Bind f (\f' =>
               Bind a (\a' =>
-              Pure (f' a')))
+              Pure (f' a')))

idris-jvm-core/src/main/idris/IdrisJvm/Core/Common.idr

@@ -96,6 +96,23 @@ repeatObjectDesc n = repeatString n "Ljava/lang/Object;"
 sig : Nat -> String
 sig nArgs = "(" ++ repeatObjectDesc nArgs ++  ")Ljava/lang/Object;"
 
+anewarray : FieldTypeDescriptor -> Asm ()
+anewarray FieldTyDescByte          = Anewbytearray
+anewarray FieldTyDescChar          = Anewchararray
+anewarray FieldTyDescShort         = Anewshortarray
+anewarray FieldTyDescBoolean       = Anewbooleanarray
+anewarray FieldTyDescArray         = jerror $ "array is not a valid element type for a single dimensional array"
+anewarray FieldTyDescDouble        = Anewdoublearray
+anewarray FieldTyDescFloat         = Anewfloatarray
+anewarray FieldTyDescInt           = Anewintarray
+anewarray FieldTyDescLong          = Anewlongarray
+anewarray (FieldTyDescReference f) = Anewarray $ asmRefTyDesc f
+
+arrayDesc : String -> Nat -> String
+arrayDesc cname dimensions =
+  let arrayPrefix = cast $ replicate dimensions '['
+  in arrayPrefix ++ cname
+
 metafactoryDesc : Descriptor
 metafactoryDesc =
   concat [ "("
@@ -131,6 +148,34 @@ invokeDynamic cname lambda nArgs =
                       , BsmArgGetType "()Ljava/lang/Object;"
                       ]
 
+arrayStore : FieldTypeDescriptor -> Asm ()
+arrayStore FieldTyDescByte = Bastore
+arrayStore FieldTyDescChar = Castore
+arrayStore FieldTyDescShort = Sastore
+arrayStore FieldTyDescBoolean = Bastore
+arrayStore FieldTyDescArray = Aastore
+arrayStore FieldTyDescDouble = Dastore
+arrayStore FieldTyDescFloat = Fastore
+arrayStore FieldTyDescInt = Iastore
+arrayStore FieldTyDescLong = Lastore
+arrayStore (FieldTyDescReference ReferenceTypeDescriptor) = Aastore
+
+arrayLoad : FieldTypeDescriptor -> Asm ()
+arrayLoad FieldTyDescByte                                = Baload
+arrayLoad FieldTyDescChar                                = Caload
+arrayLoad FieldTyDescShort                               = Saload
+arrayLoad FieldTyDescBoolean                             = Baload
+arrayLoad FieldTyDescArray                               = Aaload
+arrayLoad FieldTyDescDouble                              = Daload
+arrayLoad FieldTyDescFloat                               = Faload
+arrayLoad FieldTyDescInt                                 = Iaload
+arrayLoad FieldTyDescLong                                = Laload
+arrayLoad (FieldTyDescReference ReferenceTypeDescriptor) = Aaload
+
+typeDescToarrayElemDesc : TypeDescriptor -> FieldTypeDescriptor
+typeDescToarrayElemDesc VoidDescriptor = jerror $ "An array cannot have 'void' elements"
+typeDescToarrayElemDesc (FieldDescriptor desc) = desc
+
 loadArgsForLambdaTargetMethod : Nat -> Asm ()
 loadArgsForLambdaTargetMethod nArgs = case isLTE 1 nArgs of
     Yes prf => sequence_ (map (Aload . cast) [0 .. (Nat.(-) nArgs 1)])

idris-jvm-core/src/main/idris/IdrisJvm/Core/Foreign.idr

@@ -14,14 +14,19 @@ data JForeign = JStatic String String
               | JSetInstanceField String String
               | JInterface String String
               | JNew String
+              | JNewArray
+              | JMultiNewArray
+              | JSetArray
+              | JGetArray
+              | JArrayLength
               | JClassLiteral String
 
 mutual
   parseDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
   parseDescriptor returns ffi argsDesc = tryParseStaticMethodDescriptor returns ffi argsDesc where
 
     unsupportedDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
-    unsupportedDescriptor _ fdesc _ = jerror $ "Unsupported descriptor"
+    unsupportedDescriptor _ fdesc _ = jerror $ ("Unsupported descriptor: " ++ show fdesc)
 
     tryParseClassLiteralDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
     tryParseClassLiteralDescriptor returns ffiDesc@(FApp ffi [FStr cname]) argsDesc
@@ -30,19 +35,39 @@ mutual
           else unsupportedDescriptor returns ffiDesc argsDesc
     tryParseClassLiteralDescriptor returns ffi argsDesc = unsupportedDescriptor returns ffi argsDesc
 
+    tryParseArrayLengthDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
+    tryParseArrayLengthDescriptor returns (FCon "ArrayLength") argsDesc = JArrayLength
+    tryParseArrayLengthDescriptor returns ffi argsDesc = tryParseClassLiteralDescriptor returns ffi argsDesc
+
+    tryParseGetArrayDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
+    tryParseGetArrayDescriptor returns (FCon "GetArray") argsDesc = JGetArray
+    tryParseGetArrayDescriptor returns ffi argsDesc = tryParseArrayLengthDescriptor returns ffi argsDesc
+
+    tryParseSetArrayDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
+    tryParseSetArrayDescriptor returns (FCon "SetArray") argsDesc = JSetArray
+    tryParseSetArrayDescriptor returns ffi argsDesc = tryParseGetArrayDescriptor returns ffi argsDesc
+
+    tryParseMultiNewArrayDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
+    tryParseMultiNewArrayDescriptor returns (FCon "MultiNewArray") argsDesc = JMultiNewArray
+    tryParseMultiNewArrayDescriptor returns ffi argsDesc = tryParseSetArrayDescriptor returns ffi argsDesc
+
+    tryParseNewArrayDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
+    tryParseNewArrayDescriptor returns (FCon "NewArray") argsDesc = JNewArray
+    tryParseNewArrayDescriptor returns ffi argsDesc = tryParseMultiNewArrayDescriptor returns ffi argsDesc
+
     tryParseConstructorDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
     tryParseConstructorDescriptor returns ffiDesc@(FCon ffi) argsDesc
       = if ffi == "New"
           then case fdescRefDescriptor returns of
                   ClassDesc cname    => JNew cname
                   InterfaceDesc _    => jerror $ "Invalid FFI descriptor for constructor. " ++
                                             "A constructor can't return an interface type. "
-                  ArrayDesc _        => jerror "Array construction is not yet supported"
+                  ArrayDesc _        => jerror "No constructors for array types"
                   IdrisExportDesc _  => jerror "Cannot invoke constructor of Idris exported type"
                   NullableStrDesc    => jerror "A constructor cannot return a nullable string"
                   NullableRefDesc _  => jerror "A constructor cannot return a nullable reference"
-          else tryParseClassLiteralDescriptor returns ffiDesc argsDesc
-    tryParseConstructorDescriptor returns ffi argsDesc = tryParseClassLiteralDescriptor returns ffi argsDesc
+          else tryParseNewArrayDescriptor returns ffiDesc argsDesc
+    tryParseConstructorDescriptor returns ffi argsDesc = tryParseNewArrayDescriptor returns ffi argsDesc
 
     tryParseSetInstanceFieldDescriptor : FDesc -> FDesc -> List (FDesc, LVar) -> JForeign
     tryParseSetInstanceFieldDescriptor returns ffiDesc@(FApp ffi [FStr fieldName]) argsDesc@((declClass, _)::_)
@@ -110,6 +135,13 @@ mutual
       Aload $ locIndex v
       idrisDescToJava (FieldDescriptor ty)
 
+  idrisToJavaLoadArray : List (FieldTypeDescriptor, LVar) -> Asm ()
+  idrisToJavaLoadArray = sequence_ . intersperse Aaload . map f where
+    f : (FieldTypeDescriptor, LVar) -> Asm ()
+    f (ty, v) = do
+      Aload $ locIndex v
+      idrisDescToJava (FieldDescriptor ty)
+
   javaToIdris : TypeDescriptor -> Asm ()
   javaToIdris (FieldDescriptor FieldTyDescBoolean) =
     InvokeMethod InvokeStatic (rtClassSig "Util") "boolToIdrisBool" "(Z)Ljava/lang/Object;" False
@@ -200,23 +232,26 @@ mutual
   fdescFieldDescriptor (FApp "JVM_IntT" [_, FCon "JVM_IntBits16"]) = FieldTyDescShort
   fdescFieldDescriptor (FApp "JVM_IntT" [_, FCon "JVM_IntBits32"]) = FieldTyDescInt
   fdescFieldDescriptor (FApp "JVM_IntT" [_, FCon "JVM_IntBits64"]) = FieldTyDescLong
-  fdescFieldDescriptor (FCon "JVM_Str") = FieldTyDescReference $ ClassDesc "java/lang/String"
   fdescFieldDescriptor (FCon "JVM_Float") = FieldTyDescFloat
   fdescFieldDescriptor (FCon "JVM_Double") = FieldTyDescDouble
   fdescFieldDescriptor (FCon "JVM_Bool") = FieldTyDescBoolean
+
+  fdescFieldDescriptor (FCon "JVM_Str") = FieldTyDescReference $ ClassDesc "java/lang/String"
   fdescFieldDescriptor fdesc = FieldTyDescReference $ fdescRefDescriptor fdesc
 
   fdescRefDescriptor : FDesc -> ReferenceTypeDescriptor
   fdescRefDescriptor desc@(FApp "JVM_NativeT" [FApp "Class" [FStr typeName]]) = ClassDesc typeName
   fdescRefDescriptor desc@(FApp "JVM_NativeT" [FApp "Interface" [FStr typeName]]) = InterfaceDesc typeName
+
+  fdescRefDescriptor desc@(FApp "JVM_ArrayT" [_, elemDesc]) = ArrayDesc $ fdescFieldDescriptor elemDesc
+
   fdescRefDescriptor desc@(FApp "JVM_Nullable" [FApp "Class" [FStr typeName]]) = NullableRefDesc typeName
   fdescRefDescriptor desc@(FApp "JVM_Nullable" [FApp "Interface" [FStr typeName]]) = NullableRefDesc typeName
-  fdescRefDescriptor (FApp "JVM_NativeT" [FApp "Array" [FApp "Class" [FStr typeName]]]) = ArrayDesc (ClassDesc typeName)
+
   fdescRefDescriptor (FCon "JVM_Str") = ClassDesc "java/lang/String"
   fdescRefDescriptor (FStr exportedType) = IdrisExportDesc exportedType
   fdescRefDescriptor (FCon "JVM_NullableStr") = NullableStrDesc
-  fdescRefDescriptor desc = jerror $ "Expected a class or interface descriptor. " ++
-    "Invalid reference type descriptor: " ++ show desc
+  fdescRefDescriptor desc = jerror $ "Invalid reference type descriptor: " ++ show desc
 
   isExportIO : FDesc -> Bool
   isExportIO (FIO _) = True