Fix constant case expression scope, char conversion

Author: mmhelloworld

idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Runtime.java

@@ -136,7 +136,15 @@ public static int unwrapIntThunk(Object possibleThunk) {
         if (possibleThunk instanceof Thunk) {
             return ((Thunk) possibleThunk).getInt();
         } else {
-            return (int) possibleThunk;
+            return Conversion.toInt1(possibleThunk);
+        }
+    }
+
+    public static char unwrapIntThunkToChar(Object possibleThunk) {
+        if (possibleThunk instanceof Thunk) {
+            return (char) ((Thunk) possibleThunk).getInt();
+        } else {
+            return (char) possibleThunk;
         }
     }
 

idris-jvm-runtime/src/main/java/io/github/mmhelloworld/idrisjvm/runtime/Strings.java

@@ -31,7 +31,7 @@ public static String pack(IdrisList idrisCharacterList) {
         Object[] objectArray = idrisCharacterList.toArray();
         char[] chars = new char[objectArray.length];
         for (int index = 0; index < objectArray.length; index++) {
-            chars[index] = (char) objectArray[index];
+            chars[index] = Conversion.toChar(objectArray[index]);
         }
         return String.valueOf(chars);
     }

src/Compiler/Jvm/Asm.idr

@@ -719,7 +719,7 @@ Show Scope where
         ("parentIndex", show $ parentIndex scope),
         ("nextVariableIndex", show $ nextVariableIndex scope),
         ("lineNumbers", show $ lineNumbers scope),
-        ("labels", show $ labels scope),
+        ("variableIndices", toString $ variableIndices scope),
         ("returnType", show $ returnType scope),
         ("nextVariableIndex", show $ nextVariableIndex scope),
         ("childIndices", show $ childIndices scope)

src/Compiler/Jvm/Codegen.idr

@@ -1220,12 +1220,6 @@ mutual
             assembleCaseWithScope labelStart labelEnd expr
 
     assembleConstantSwitch returnType constantType fc sc alts def = do
-            constantExprVariableSuffixIndex <- newDynamicVariableIndex
-            let constantExprVariableName = "constantCaseExpr" ++ show constantExprVariableSuffixIndex
-            constantExprVariableIndex <- getVariableIndex constantExprVariableName
-            hashCodePositionVariableSuffixIndex <- newDynamicVariableIndex
-            let hashCodePositionVariableName = "hashCodePosition" ++ show hashCodePositionVariableSuffixIndex
-            hashCodePositionVariableIndex <- getVariableIndex hashCodePositionVariableName
             hashPositionAndAlts <- traverse (constantAltHashCodeExpr fc) $
                 List.zip [0 .. the Int $ cast $ length $ drop 1 alts] alts
             let positionAndAltsByHash = multiValueMap fst snd hashPositionAndAlts
@@ -1236,6 +1230,12 @@ mutual
             CreateLabel switchEndLabel
             traverse_ CreateLabel labels
             assembleExpr False constantType sc
+            constantExprVariableSuffixIndex <- newDynamicVariableIndex
+            let constantExprVariableName = "constantCaseExpr" ++ show constantExprVariableSuffixIndex
+            constantExprVariableIndex <- getVariableIndex constantExprVariableName
+            hashCodePositionVariableSuffixIndex <- newDynamicVariableIndex
+            let hashCodePositionVariableName = "hashCodePosition" ++ show hashCodePositionVariableSuffixIndex
+            hashCodePositionVariableIndex <- getVariableIndex hashCodePositionVariableName
             storeVar constantType constantType constantExprVariableIndex
             constantClass <- getHashCodeSwitchClass fc constantType
             Iconst (-1)

src/Compiler/Jvm/Optimizer.idr

@@ -82,7 +82,7 @@ getLineNumbers (lineStart, _) (lineEnd, colEnd) =
 
 getFileName : OriginDesc -> String
 getFileName (PhysicalIdrSrc moduleIdent) = case unsafeUnfoldModuleIdent moduleIdent of
-  (moduleName :: _) => moduleName
+  (moduleName :: _) => moduleName ++ ".idr"
   _ => "(unknown-source)"
 getFileName (PhysicalPkgSrc fname) = fname
 getFileName (Virtual Interactive) = "(Interactive)"
@@ -470,13 +470,21 @@ getConstantType : List NamedConstAlt -> Asm InferredType
 getConstantType [] = Throw emptyFC "Unknown constant switch type"
 getConstantType ((MkNConstAlt constant _) :: _) = case constant of
     I _ => Pure IInt
+    B8 _ => Pure IInt
+    B16 _ => Pure IInt
+    B32 _ => Pure IInt
     Ch _ => Pure IInt
     Str _ => Pure inferredStringType
     BI _ => Pure inferredBigIntegerType
+    B64 _ => Pure inferredBigIntegerType
     unsupportedConstant => Throw emptyFC $ "Unsupported constant switch " ++ show unsupportedConstant
 
 export
 isTypeConst : TT.Constant -> Bool
+isTypeConst Bits8Type   = True
+isTypeConst Bits16Type  = True
+isTypeConst Bits32Type  = True
+isTypeConst Bits64Type  = True
 isTypeConst IntType     = True
 isTypeConst IntegerType = True
 isTypeConst StringType  = True
@@ -488,6 +496,9 @@ isTypeConst _           = False
 export
 getIntConstantValue : FC -> TT.Constant -> Asm Int
 getIntConstantValue _ (I i) = Pure i
+getIntConstantValue _ (B8 i) = Pure i
+getIntConstantValue _ (B16 i) = Pure i
+getIntConstantValue _ (B32 i) = Pure i
 getIntConstantValue _ (Ch c) = Pure $ ord c
 getIntConstantValue _ WorldVal = Pure 0
 getIntConstantValue fc x =

src/Compiler/Jvm/ShowUtil.idr

@@ -22,6 +22,22 @@ showType typeName properties = showObj (("__name", quoted typeName) :: propertie
 indent : Nat -> String -> String
 indent n s = concat (List.replicate (n * 4) " ") ++ s
 
+showConstant : Constant -> String
+showConstant (I value)   = "prim$I$" ++ show value
+showConstant (BI value)  = "prim$BI$" ++ show value
+showConstant (Ch value)  = "prim$Ch$" ++ show value
+showConstant (Str value) = "prim$Str$" ++ show value
+showConstant (I8 value)  = "prim$I8$" ++ show value
+showConstant (I16 value) = "prim$I16$" ++ show value
+showConstant (I32 value) = "prim$I32$" ++ show value
+showConstant (I64 value) = "prim$I64$" ++ show value
+showConstant (B8 value)  = "prim$B8$" ++ show value
+showConstant (B16 value) = "prim$B16$" ++ show value
+showConstant (B32 value) = "prim$B32$" ++ show value
+showConstant (B64 value) = "prim$B64$" ++ show value
+showConstant (Db value)  = "prim$Db$" ++ show value
+showConstant value       = "prim$" ++ show value
+
 mutual
     export
     showNamedCExp : Nat -> NamedCExp -> String
@@ -43,17 +59,16 @@ mutual
     showNamedCExp n (NmForce _ _ x) = "force" ++ "(" ++ showNamedCExp n x ++ ")"
     showNamedCExp n (NmDelay _ _ x) = "delay" ++ "(" ++ showNamedCExp n x ++ ")"
     showNamedCExp n (NmConCase fc sc xs def) = "\n" ++
-        indent n ("constructorswitch" ++ "(" ++ showNamedCExp n sc ++ ") \n") ++
+        indent n ("constructorswitch" ++ "(" ++ showNamedCExp n sc ++ ")\n") ++
             showSep "\n" (showNamedConAlt (n + 1) <$> xs) ++
                 maybe "" (\defExp => "\n" ++ indent (n + 1) "default:\n" ++
                     indent (n + 1) (showNamedCExp (n + 1) defExp)) def
     showNamedCExp n (NmConstCase fc sc xs def) = "\n" ++
-        indent n ("constantswitch" ++"(" ++ show sc ++ ")\n") ++
+        indent n ("constantswitch" ++"(" ++ showNamedCExp n sc ++ ")\n") ++
             showSep "\n" (showNamedConstAlt (n + 1) <$> xs) ++
                 maybe "" (\defExp => "\n" ++ indent (n + 1) "default:\n" ++
                     indent (n + 1) (showNamedCExp (n + 2) defExp)) def
-    showNamedCExp n (NmPrimVal fc (BI value)) = "prim$BI$" ++ show value
-    showNamedCExp n (NmPrimVal fc x) = "prim$" ++ show x
+    showNamedCExp n (NmPrimVal fc x) = showConstant x
     showNamedCExp n (NmErased fc) = "erased"
     showNamedCExp n (NmCrash fc x) = "crash " ++ show x
 
@@ -65,7 +80,7 @@ mutual
 
     export
     showNamedConstAlt : Nat -> NamedConstAlt -> String
-    showNamedConstAlt n (MkNConstAlt x exp) = indent n ("case " ++ show x ++ ":\n") ++
+    showNamedConstAlt n (MkNConstAlt x exp) = indent n ("case " ++ showConstant x ++ ":\n") ++
         indent (n + 1) (showNamedCExp (n + 1) exp)
 
 

src/Compiler/Jvm/Variable.idr

@@ -92,6 +92,9 @@ unboxToDoubleThunk =
 unwrapIntThunk : Asm ()
 unwrapIntThunk = InvokeMethod InvokeStatic runtimeClass "unwrapIntThunk" "(Ljava/lang/Object;)I" False
 
+unwrapIntThunkToChar : Asm ()
+unwrapIntThunkToChar = InvokeMethod InvokeStatic runtimeClass "unwrapIntThunkToChar" "(Ljava/lang/Object;)C" False
+
 unwrapLongThunk : Asm ()
 unwrapLongThunk = InvokeMethod InvokeStatic runtimeClass "unwrapLongThunk" "(Ljava/lang/Object;)J" False
 
@@ -295,7 +298,7 @@ loadAndUnboxByte ty sourceLocTys var =
 
 loadAndUnboxChar : InferredType -> Map Int InferredType -> Int -> Asm ()
 loadAndUnboxChar ty sourceLocTys var =
-    let loadInstr = \index => do Aload index; if ty == intThunkType then unwrapIntThunk else objToChar
+    let loadInstr = \index => do Aload index; if ty == intThunkType then unwrapIntThunkToChar else objToChar
     in opWithWordSize sourceLocTys loadInstr var
 
 loadAndUnboxShort : InferredType -> Map Int InferredType -> Int -> Asm ()