#79 Compile Blodwen for JVM

Author: mmhelloworld

.editorconfig

@@ -0,0 +1,8 @@
+root = true
+
+[*]
+indent_style = space
+end_of_line = lf
+charset = utf-8
+trim_trailing_whitespace = true
+insert_final_newline = true

.gitignore

@@ -3,6 +3,7 @@
 
 # Idris
 *.ibc
+.idrisjvmtypes*
 
 # IDE
 .idea

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

@@ -94,29 +94,11 @@ Show InferredType where
     show IUnknown = "unknown"
 
 Semigroup InferredType where
-  IUnknown <+> known = known
-  known <+> IUnknown = known
   ty1 <+> ty2 = if ty1 == ty2 then ty1 else inferredObjectType
 
 Monoid InferredType where
   neutral = IUnknown
 
-toFrameLocalVarType : InferredType -> String
-toFrameLocalVarType IBool = "INTEGER"
-toFrameLocalVarType IByte = "INTEGER"
-toFrameLocalVarType IChar = "INTEGER"
-toFrameLocalVarType IShort = "INTEGER"
-toFrameLocalVarType IInt = "INTEGER"
-toFrameLocalVarType ILong = "LONG"
-toFrameLocalVarType IFloat = "FLOAT"
-toFrameLocalVarType IDouble = "DOUBLE"
-toFrameLocalVarType (Ref clsName) = clsName
-toFrameLocalVarType (IArray elemTy) = "[" ++ toFrameLocalVarType elemTy
-toFrameLocalVarType _ = "java/lang/Object"
-
-toFrameLocalVarTypes : InferredTypeStore -> List String
-toFrameLocalVarTypes types = toFrameLocalVarType <$> (values types)
-
 isPrimitive : InferredType -> Bool
 isPrimitive IBool = True
 isPrimitive IByte = True
@@ -507,4 +489,4 @@ isExportedDesc _ = False
 
 isExportedReturnDesc : TypeDescriptor -> Bool
 isExportedReturnDesc (FieldDescriptor (FieldTyDescReference (IdrisExportDesc _))) = True
-isExportedReturnDesc _ = False
+isExportedReturnDesc _ = False

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

@@ -116,11 +116,37 @@ metafactoryDesc =
 unrolledConstructorPropsCount : Nat
 unrolledConstructorPropsCount = 10
 
-idrisObjectProperty : Int -> Int -> Asm ()
-idrisObjectProperty object propertyIndex = do
-  Aload object
-  Iconst propertyIndex
-  InvokeMethod InvokeStatic idrisObjectType "getProperty" "(Ljava/lang/Object;I)Ljava/lang/Object;" False
+inferredTypeToFieldTypeDesc : InferredType -> FieldTypeDescriptor
+inferredTypeToFieldTypeDesc IBool = FieldTyDescBoolean
+inferredTypeToFieldTypeDesc IByte = FieldTyDescByte
+inferredTypeToFieldTypeDesc IChar = FieldTyDescChar
+inferredTypeToFieldTypeDesc IShort = FieldTyDescShort
+inferredTypeToFieldTypeDesc IInt = FieldTyDescInt
+inferredTypeToFieldTypeDesc ILong = FieldTyDescLong
+inferredTypeToFieldTypeDesc IFloat = FieldTyDescFloat
+inferredTypeToFieldTypeDesc IDouble = FieldTyDescDouble
+inferredTypeToFieldTypeDesc (Ref refTy) = FieldTyDescReference (ClassDesc refTy)
+inferredTypeToFieldTypeDesc IUnknown = FieldTyDescReference (ClassDesc "java/lang/Object")
+inferredTypeToFieldTypeDesc (IArray elemTy) = FieldTyDescReference (ArrayDesc $ inferredTypeToFieldTypeDesc elemTy)
+
+getInferredTyDesc : InferredType -> String
+getInferredTyDesc = asmFieldTypeDesc . inferredTypeToFieldTypeDesc
+
+toFrameLocalVarType : InferredType -> String
+toFrameLocalVarType IBool = "INTEGER"
+toFrameLocalVarType IByte = "INTEGER"
+toFrameLocalVarType IChar = "INTEGER"
+toFrameLocalVarType IShort = "INTEGER"
+toFrameLocalVarType IInt = "INTEGER"
+toFrameLocalVarType ILong = "LONG"
+toFrameLocalVarType IFloat = "FLOAT"
+toFrameLocalVarType IDouble = "DOUBLE"
+toFrameLocalVarType (Ref clsName) = clsName
+toFrameLocalVarType (IArray elemTy) = "[" ++ getInferredTyDesc elemTy
+toFrameLocalVarType _ = "java/lang/Object"
+
+toFrameLocalVarTypes : InferredTypeStore -> List String
+toFrameLocalVarTypes types = toFrameLocalVarType <$> (values types)
 
 fullFrame : Asm ()
 fullFrame = do
@@ -156,22 +182,6 @@ invokeError x = do
 getPrimitiveClass : String -> Asm ()
 getPrimitiveClass clazz = Field FGetStatic clazz "TYPE" "Ljava/lang/Class;"
 
-inferredTypeToFieldTypeDesc : InferredType -> FieldTypeDescriptor
-inferredTypeToFieldTypeDesc IBool = FieldTyDescBoolean
-inferredTypeToFieldTypeDesc IByte = FieldTyDescByte
-inferredTypeToFieldTypeDesc IChar = FieldTyDescChar
-inferredTypeToFieldTypeDesc IShort = FieldTyDescShort
-inferredTypeToFieldTypeDesc IInt = FieldTyDescInt
-inferredTypeToFieldTypeDesc ILong = FieldTyDescLong
-inferredTypeToFieldTypeDesc IFloat = FieldTyDescFloat
-inferredTypeToFieldTypeDesc IDouble = FieldTyDescDouble
-inferredTypeToFieldTypeDesc (Ref refTy) = FieldTyDescReference (ClassDesc refTy)
-inferredTypeToFieldTypeDesc IUnknown = FieldTyDescReference (ClassDesc "java/lang/Object")
-inferredTypeToFieldTypeDesc (IArray elemTy) = FieldTyDescReference (ArrayDesc $ inferredTypeToFieldTypeDesc elemTy)
-
-getInferredTyDesc : InferredType -> String
-getInferredTyDesc = asmFieldTypeDesc . inferredTypeToFieldTypeDesc
-
 getInferredFunDesc : List InferredType -> InferredType -> String
 getInferredFunDesc [] retTy = "()" ++ getInferredTyDesc retTy
 getInferredFunDesc argTypes retTy =
@@ -513,38 +523,54 @@ storeVar IFloat (Ref _) var = boxStore boxFloat var
 storeVar IDouble IUnknown var = boxStore boxDouble var
 storeVar IDouble (Ref _) var = boxStore boxDouble var
 
-storeVar IUnknown IBool var = storeVarWithWordSize (\index => do unboxBool; Istore index) var
-storeVar (Ref _) IBool var = storeVarWithWordSize (\index => do unboxBool; Istore index) var
+storeVar IUnknown IBool var = storeVarWithWordSize (\index => do cgCast IUnknown IBool; Istore index) var
+storeVar srcTy@(Ref _) IBool var = storeVarWithWordSize (\index => do cgCast srcTy IBool; Istore index) var
 
-storeVar IUnknown IByte var = storeVarWithWordSize (\index => do unboxByte; Istore index) var
-storeVar (Ref _) IByte var = storeVarWithWordSize (\index => do unboxByte; Istore index) var
+storeVar IUnknown IByte var = storeVarWithWordSize (\index => do cgCast IUnknown IByte; Istore index) var
+storeVar srcTy@(Ref _) IByte var = storeVarWithWordSize (\index => do cgCast srcTy IByte; Istore index) var
 
-storeVar IUnknown IChar var = storeVarWithWordSize (\index => do unboxChar; Istore index) var
-storeVar (Ref _) IChar var = storeVarWithWordSize (\index => do unboxChar; Istore index) var
+storeVar IUnknown IChar var = storeVarWithWordSize (\index => do cgCast IUnknown IChar; Istore index) var
+storeVar srcTy@(Ref _) IChar var = storeVarWithWordSize (\index => do cgCast srcTy IChar; Istore index) var
 
-storeVar IUnknown IShort var = storeVarWithWordSize (\index => do unboxShort; Istore index) var
-storeVar (Ref _) IShort var = storeVarWithWordSize (\index => do unboxShort; Istore index) var
+storeVar IUnknown IShort var = storeVarWithWordSize (\index => do cgCast IUnknown IShort; Istore index) var
+storeVar srcTy@(Ref _) IShort var = storeVarWithWordSize (\index => do cgCast srcTy IShort; Istore index) var
 
-storeVar IUnknown IInt var = storeVarWithWordSize (\index => do unboxInt; Istore index) var
-storeVar (Ref _) IInt var = storeVarWithWordSize (\index => do unboxInt; Istore index) var
+storeVar IUnknown IInt var = storeVarWithWordSize (\index => do cgCast IUnknown IInt; Istore index) var
+storeVar srcTy@(Ref _) IInt var = storeVarWithWordSize (\index => do cgCast srcTy IInt; Istore index) var
 
-storeVar IUnknown ILong var = storeVarWithWordSize (\index => do unboxLong; Lstore index) var
-storeVar (Ref _) ILong var = storeVarWithWordSize (\index => do unboxLong; Lstore index) var
+storeVar IUnknown ILong var = storeVarWithWordSize (\index => do cgCast IUnknown ILong; Lstore index) var
+storeVar srcTy@(Ref _) ILong var = storeVarWithWordSize (\index => do cgCast srcTy ILong; Lstore index) var
 
-storeVar IUnknown IFloat var = storeVarWithWordSize (\index => do unboxFloat; Fstore index) var
-storeVar (Ref _) IFloat var = storeVarWithWordSize (\index => do unboxFloat; Fstore index) var
+storeVar IUnknown IFloat var = storeVarWithWordSize (\index => do cgCast IUnknown IFloat; Fstore index) var
+storeVar srcTy@(Ref _) IFloat var = storeVarWithWordSize (\index => do cgCast srcTy IFloat; Fstore index) var
 
-storeVar IUnknown IDouble var = storeVarWithWordSize (\index => do unboxDouble; Dstore index) var
-storeVar (Ref _) IDouble var = storeVarWithWordSize (\index => do unboxDouble; Dstore index) var
+storeVar IUnknown IDouble var = storeVarWithWordSize (\index => do cgCast IUnknown IDouble; Dstore index) var
+storeVar srcTy@(Ref _) IDouble var = storeVarWithWordSize (\index => do cgCast srcTy IDouble; Dstore index) var
 
 storeVar IUnknown arr@(IArray elemTy) var =
     storeVarWithWordSize (\index => do Checkcast $ getInferredTyDesc arr; Astore index) var
 storeVar (Ref _) arr@(IArray elemTy) var =
     storeVarWithWordSize (\index => do Checkcast $ getInferredTyDesc arr; Astore index) var
 
-storeVar (Ref _) (Ref _) var = do types <- GetFunctionLocTypes; opWithWordSize types Astore var
+storeVar IUnknown targetTy@(Ref _) var = do
+    types <- GetFunctionLocTypes
+    cgCast IUnknown targetTy
+    opWithWordSize types Astore var
+
+storeVar srcTy@(Ref _) targetTy@(Ref _) var = do
+    types <- GetFunctionLocTypes
+    cgCast srcTy targetTy
+    opWithWordSize types Astore var
+
 storeVar _ _ var = do types <- GetFunctionLocTypes; opWithWordSize types Astore var
 
+idrisObjectProperty : Int -> Int -> Asm ()
+idrisObjectProperty object propertyIndex = do
+  locTypes <- GetFunctionLocTypes
+  loadVar locTypes inferredObjectType inferredObjectType (Loc object)
+  Iconst propertyIndex
+  InvokeMethod InvokeStatic idrisObjectType "getProperty" "(Ljava/lang/Object;I)Ljava/lang/Object;" False
+
 assign : (lhs: List LVar) -> (rhs: List LVar) -> Asm ()
 assign lhs rhs = do
     locTypes <- GetFunctionLocTypes
@@ -570,4 +596,4 @@ unwrapExportedIO = do
   let desc = getInferredFunDesc argTys retTy
   cgCast inferredObjectType lastArgTy
   InvokeMethod InvokeStatic "main/Main" "call__IO" desc False
-  InvokeMethod InvokeStatic (rtClass "Runtime") "unwrap" (sig 1) False
+  InvokeMethod InvokeStatic (rtClass "Runtime") "unwrap" (sig 1) False

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

@@ -150,23 +150,20 @@ mutual
     cgCase ret cgBody label expr
     Goto $ switchEndLabel si
 
-  cgAlt : (InferredType -> Asm ()) -> ((InferredType -> Asm ()) -> SExp -> Asm ()) -> Label -> Nat -> Int -> SAlt -> Asm ()
-  cgAlt ret cgBody label si _ (SConstCase _ expr) = cgAltNonConCase ret cgBody label si expr
-
-  cgAlt ret cgBody label si _ (SDefaultCase expr) = cgAltNonConCase ret cgBody label si expr
-
-  cgAlt ret cgBody label si sv (SConCase lv _ _ args expr) = do
-      LabelStart label
-      addFrame
+  cgConCase : (InferredType -> Asm ())
+            -> ((InferredType -> Asm ()) -> SExp -> Asm ())
+            -> Int
+            -> Int
+            -> List String
+            -> SExp
+            -> Asm ()
+  cgConCase ret cgBody idrisObject lv args expr = do
       extractConParams lv
       cgBody ret expr
-
-      Goto $ switchEndLabel si
-
     where
       project : Nat -> Nat -> Asm ()
       project i v = do
-        idrisObjectProperty sv (cast i)
+        idrisObjectProperty idrisObject (cast i)
         Astore $ cast v
 
       argsLength : Nat
@@ -182,6 +179,17 @@ mutual
                 project (cast i) (cast v)
                 go (i + 1) (v + 1)
 
+  cgAlt : (InferredType -> Asm ()) -> ((InferredType -> Asm ()) -> SExp -> Asm ()) -> Label -> Nat -> Int -> SAlt -> Asm ()
+  cgAlt ret cgBody label si _ (SConstCase _ expr) = cgAltNonConCase ret cgBody label si expr
+
+  cgAlt ret cgBody label si _ (SDefaultCase expr) = cgAltNonConCase ret cgBody label si expr
+
+  cgAlt ret cgBody label si sv (SConCase lv _ _ args expr) = do
+      LabelStart label
+      addFrame
+      cgConCase ret cgBody sv lv args expr
+      Goto $ switchEndLabel si
+
   conCase : SAlt -> Bool
   conCase (SConCase _ _ _ _ _) = True
   conCase _           = False

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

@@ -116,32 +116,6 @@ typeDescriptorToInferredType (ThrowableDescriptor _) = inferredObjectType
 typeDescriptorToInferredType VoidDescriptor          = IUnknown
 typeDescriptorToInferredType (FieldDescriptor fieldTyDesc) = fieldTypeDescriptorToInferredType fieldTyDesc
 
-loadJavaVar : Int -> FieldTypeDescriptor -> Asm ()
-loadJavaVar index FieldTyDescBoolean = Iload index
-loadJavaVar index FieldTyDescByte    = Iload index
-loadJavaVar index FieldTyDescShort   = Iload index
-loadJavaVar index FieldTyDescInt     = Iload index
-loadJavaVar index FieldTyDescChar    = Iload index
-loadJavaVar index FieldTyDescLong    = Lload index
-loadJavaVar index FieldTyDescFloat   = Fload index
-loadJavaVar index FieldTyDescDouble  = Dload index
-loadJavaVar index (FieldTyDescReference (IdrisExportDesc cname)) = do
-  Aload index
-  InvokeMethod InvokeVirtual cname "getValue" "()Ljava/lang/Object;" False
-  checkcast idrisObjectType
-loadJavaVar index _                  = Aload index
-
-storeJavaVar : Int -> FieldTypeDescriptor -> Asm ()
-storeJavaVar index FieldTyDescBoolean = Istore index
-storeJavaVar index FieldTyDescByte    = Istore index
-storeJavaVar index FieldTyDescShort   = Istore index
-storeJavaVar index FieldTyDescInt     = Istore index
-storeJavaVar index FieldTyDescChar    = Istore index
-storeJavaVar index FieldTyDescLong    = Lstore index
-storeJavaVar index FieldTyDescFloat   = Fstore index
-storeJavaVar index FieldTyDescDouble  = Dstore index
-storeJavaVar index _                  = Astore index
-
 idrisToJava : List (FieldTypeDescriptor, LVar) -> Asm ()
 idrisToJava vars = do
     locTypes <- GetFunctionLocTypes

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

@@ -223,9 +223,14 @@ mutual
                          _))
     = cgIfNull ret cgBody e nothingExpr defaultExpr
 
+  cgBody ret (SCase _ e [SConCase lv _ _ args expr]) = cgConCase ret cgBody (locIndex e) lv args expr
+
   cgBody ret (SCase _ e [SDefaultCase defaultCaseExpr]) = cgBody ret defaultCaseExpr
 
-  cgBody ret (SCase _ e alts) = cgSwitch ret cgBody e alts
+  cgBody ret (SCase _ e alts) =
+    if any defaultCase alts
+        then cgSwitch ret cgBody e alts
+        else cgSwitch ret cgBody e (alts ++ [SDefaultCase SNothing])
 
   cgBody ret (SChkCase e [SDefaultCase defaultCaseExpr]) = cgBody ret defaultCaseExpr
 
@@ -235,7 +240,7 @@ mutual
 
   cgBody ret (SOp op args) = cgOp ret op args
 
-  cgBody ret SNothing = do Iconst 0; ret IInt
+  cgBody ret SNothing = do Aconstnull; ret inferredObjectType
 
   cgBody ret (SError x) = do invokeError (show x); ret IUnknown
 
@@ -260,6 +265,9 @@ mutual
     retVoidOrBoxed VoidDescriptor = Aconstnull
     retVoidOrBoxed returnDesc = box (inferredRetTy returnDesc)
 
+    synthenticMethodArgTys : InferredTypeStore
+    synthenticMethodArgTys = SortedMap.fromList $ List.zip targetArgIndices $ replicate argsLength inferredObjectType
+
     targetLocTys : InferredTypeStore
     targetLocTys =
       let targetArgTys = List.zip targetArgIndices $ fst <$> args
@@ -270,8 +278,9 @@ mutual
       ThrowableDescriptor returnDesc => do
         locTys <- GetFunctionLocTypes
         let descriptor = asmMethodDesc $ MkMethodDescriptor (fdescFieldDescriptor . fst <$> args) returnDesc
+        let arity = length args
         let lambdaBody = do
-          loadVars locTys targetLocTys lambdaArgVars
+          loadVars synthenticMethodArgTys targetLocTys lambdaArgVars
           InvokeMethod InvokeStatic clazz fn descriptor False
           retVoidOrBoxed returnDesc
         caller <- GetFunctionName
@@ -308,7 +317,7 @@ mutual
         let descriptor = asmMethodDesc $ MkMethodDescriptor (fdescFieldDescriptor . fst <$> drop 1 args) returnDesc
         locTys <- GetFunctionLocTypes
         let lambdaBody = do
-          loadVars locTys targetLocTys lambdaArgVars
+          loadVars synthenticMethodArgTys targetLocTys lambdaArgVars
           InvokeMethod InvokeVirtual clazz fn descriptor False
           retVoidOrBoxed returnDesc
         caller <- GetFunctionName
@@ -348,7 +357,7 @@ mutual
           locTys <- GetFunctionLocTypes
           let descriptor = asmMethodDesc $ MkMethodDescriptor (fdescFieldDescriptor . fst <$> drop 1 args) returnDesc
           let lambdaBody = do
-            loadVars locTys targetLocTys lambdaArgVars
+            loadVars synthenticMethodArgTys targetLocTys lambdaArgVars
             InvokeMethod InvokeInterface clazz fn descriptor True
             retVoidOrBoxed returnDesc
           caller <- GetFunctionName
@@ -371,7 +380,7 @@ mutual
         let lambdaBody = do
           New clazz
           Dup
-          loadVars locTys targetLocTys lambdaArgVars
+          loadVars synthenticMethodArgTys targetLocTys lambdaArgVars
           InvokeMethod InvokeSpecial clazz "<init>" descriptor False
         caller <- GetFunctionName
         let targetMethodName = MkJMethodName clazz "<init>"