Resolves #648, #942 - Class splitting and string constants

typelead · Feb 1, 2019 · 3980ed6 · 3980ed6
1 parent b7491ff
commit 3980ed6
Show file tree

Hide file tree

Showing 9 changed files with 85 additions and 38 deletions.
diff --git a/codec-jvm b/codec-jvm
diff --git a/compiler/Eta/CodeGen/Bind.hs b/compiler/Eta/CodeGen/Bind.hs
@@ -128,7 +128,7 @@ closureCodeBody topLevel id lfInfo args mFunRecIds arity body fvs binderIsFV rec
          let argLocs = argLocsFrom False 1 args
              argFts  = map locFt argLocs
              callStaticMethod =
-                  invokestatic (mkMethodRef modClass closureName (contextType:argFts)
+                  invokestatic (mkMethodRef thisClass "call" (contextType:argFts)
                                  (ret closureType))
                -- TODO: Make the return type fine-grained
                <> greturn closureType
@@ -150,7 +150,7 @@ closureCodeBody topLevel id lfInfo args mFunRecIds arity body fvs binderIsFV rec
                    <> fold (map loadLoc argLocs')
                    <> callStaticMethod
            _ -> return ()
-         withModClass $ withMethod [Public, Static] closureName (contextType:argFts) (ret closureType) $ do
+         withMethod [Public, Static] "call" (contextType:argFts) (ret closureType) $ do
            loadContext <- getContextLoc
            case mFunRecIds of
              Just (n, funRecIds)

diff --git a/compiler/Eta/CodeGen/Main.hs b/compiler/Eta/CodeGen/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings, LambdaCase, MultiWayIf #-}
 module Eta.CodeGen.Main where
 
 import Eta.BasicTypes.Module
@@ -11,8 +11,9 @@ import Eta.Main.DynFlags
 import Eta.BasicTypes.Id
 import Eta.BasicTypes.Name
 import Eta.BasicTypes.DataCon
+import Eta.BasicTypes.Unique
 import Eta.Utils.Digraph
-import Eta.Prelude.PrelNames (rOOT_MAIN)
+import Eta.Prelude.PrelNames (rOOT_MAIN, unpackCStringIdKey, unpackCStringUtf8IdKey)
 
 import Eta.Utils.Util
 
@@ -34,6 +35,7 @@ import Codec.JVM
 import Data.Foldable
 import Data.Monoid
 import Data.Maybe
+import Data.Functor (($>))
 import Control.Monad hiding (void)
 
 import Data.Text (Text, append)
@@ -197,44 +199,50 @@ cgTopRhsClosure :: DynFlags
                 -> StgExpr
                 -> (CgIdInfo, CodeGen (Maybe RecInfo))
 cgTopRhsClosure dflags recflag mFunRecIds id _binderInfo updateFlag args body
-  = (cgIdInfo, genCode)
+  = (cgIdInfo, genCode $> Nothing)
   where cgIdInfo = mkCgIdInfo dflags id (Just clType) lfInfo
         lfInfo = mkClosureLFInfo id TopLevel [] updateFlag args
         (modClass, clName, clClass) = getJavaInfo dflags cgIdInfo
         qClName = closure clName
-        clType
-          | StgApp _ [] <- body, null args, isNonRec recflag
-          = indStaticType
-          | otherwise = obj clClass
-        genCode
-          | StgApp f [] <- body, null args, isNonRec recflag
-          = do cgInfo <- getCgIdInfo f
-               defineField $ mkFieldDef [Private, Static, Volatile] qClName closureType
-               let field = mkFieldRef modClass qClName closureType
-                   loadCode = idInfoLoadCode cgInfo
-                   initField =
-                       [
-                         new indStaticType
-                       , dup indStaticType
-                       , loadCode
-                       , invokespecial $ mkMethodRef stgIndStatic "<init>" [closureType] void
-                       , putstatic field
-                       ]
-               defineMethod $ initCodeTemplate True modClass qClName field
-                              (fold initField)
-               return Nothing
-          | otherwise = do
-            let arity = length args
-            (_, CgState { cgClassName }) <- forkClosureBody $
+        clFt = obj clClass
+        (clType, genCode)
+          | null args, isNonRec recflag = rest
+          | otherwise = (clFt, genCodeDefault)
+          where rest
+                  | StgApp f [] <- body =
+                    templateGenCode stgIndStatic [closureType] $ idInfoLoadCode <$> getCgIdInfo f
+                  | StgApp unpack [arg] <- body
+                  ,    unpack `hasKey` unpackCStringIdKey
+                    || unpack `hasKey` unpackCStringUtf8IdKey
+                  , Just string <- simpleStringLiteral arg =
+                    templateGenCode stringCAF [jstring] $ return (sconst string)
+                  | otherwise = (clFt, genCodeDefault)
+
+        templateGenCode cls initFts initCode =
+          (ft,
+           do defineField $ mkFieldDef [Private, Static, Volatile] qClName closureType
+              loadCode <- initCode
+              let field = mkFieldRef modClass qClName closureType
+                  initField =
+                    [ new ft
+                    , dup ft
+                    , loadCode
+                    , invokespecial $ mkMethodRef cls "<init>" initFts void
+                    , putstatic field ]
+              defineMethod $ initCodeTemplate True modClass qClName field (fold initField))
+          where ft = obj cls
+
+        genCodeDefault = do
+          let arity = length args
+          (_, CgState { cgClassName }) <- forkClosureBody $
               closureCodeBody True id lfInfo
                               (nonVoidIds args) mFunRecIds arity body [] False []
 
-            let ft = obj cgClassName
-            defineMethod $
+          let ft = obj cgClassName
+          defineMethod $
               mkMethodDef modClass [Public, Static] qClName [] (ret closureType) $
                   getstatic (mkFieldRef cgClassName singletonInstanceName ft)
                <> greturn ft
-            return Nothing
 
 -- Simplifies the code if the mod is associated to the Id
 externaliseId :: Id -> CodeGen Id

diff --git a/compiler/Eta/CodeGen/Rts.hs b/compiler/Eta/CodeGen/Rts.hs
@@ -362,3 +362,6 @@ getClosureMethod int =
 
 indirecteeField :: Code
 indirecteeField = getfield (mkFieldRef stgThunk "indirectee" closureType)
+
+stringCAF :: Text
+stringCAF = "eta/base/StringCAF"
diff --git a/compiler/Eta/CodeGen/Types.hs b/compiler/Eta/CodeGen/Types.hs
@@ -179,9 +179,9 @@ loadLoc (LocStablePtr int) = getClosureMethod int
 loadLoc loc = pprPanic "loadLoc" $ ppr loc
 
 loadStaticMethod :: CgLoc -> [FieldType] -> Maybe Code
-loadStaticMethod (LocStatic _ft modClass clName) fts =
-  Just $ invokestatic $ mkMethodRef modClass (closure clName) (contextType:fts)
-           (ret closureType)
+loadStaticMethod (LocStatic _ modClass clName) fts =
+  Just $ invokestatic $ mkMethodRef (qualifiedName modClass clName) "call"
+           (contextType:fts) (ret closureType)
 loadStaticMethod _loc _fts = Nothing
 
 locClass :: CgLoc -> Maybe Text

diff --git a/compiler/Eta/CodeGen/Utils.hs b/compiler/Eta/CodeGen/Utils.hs
@@ -8,10 +8,12 @@ import Eta.BasicTypes.BasicTypes
 import Eta.BasicTypes.DataCon (DataCon)
 import Eta.BasicTypes.Id
 import Eta.BasicTypes.Literal
+import Eta.StgSyn.StgSyn
 import Codec.JVM
 import Codec.JVM.Encoding
 import Data.Char (ord)
 import Control.Arrow(first)
+import Control.Monad(guard)
 import Eta.CodeGen.Name
 import Eta.CodeGen.Rts
 import Eta.Debug
@@ -81,6 +83,15 @@ cgLit (MachStr s)           = (jlong, genCode)
 cgLit MachLabel {}          = error "cgLit: MachLabel"
 cgLit other                 = pprPanic "mkSimpleLit" (ppr other)
 
+simpleStringLiteral :: GenStgArg occ -> Maybe Text
+simpleStringLiteral (StgLitArg (MachStr bs)) = do
+  string <- unsafeDupablePerformIO $
+     catch (fmap Just $ evaluate $ decodeUtf8 bs)
+           (\(_ :: SomeException) -> return Nothing)
+  guard (BL.length (encodeModifiedUtf8 string) < 65535)
+  return string
+simpleStringLiteral _ = Nothing
+
 litToInt :: Literal -> Int
 litToInt (MachInt i)  = fromInteger i
 litToInt (MachWord i) = fromInteger i

diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
@@ -65,7 +65,7 @@ library
         Unsafe
 
     build-depends: rts == 0.1.*, ghc-prim == 0.4.*, integer >= 0.5.1
-    java-sources: java-utils/Utils.java,java-utils/HSIConv.java
+    java-sources: java-utils/Utils.java,java-utils/HSIConv.java,java-utils/StringCAF.java
 
     exposed-modules:
         Control.Applicative

diff --git a/libraries/base/java-utils/StringCAF.java b/libraries/base/java-utils/StringCAF.java
@@ -0,0 +1,25 @@
+package eta.base;
+
+import eta.runtime.stg.Closure;
+import eta.runtime.stg.StgContext;
+import eta.runtime.thunk.CAF;
+import eta.base.Utils;
+
+public class StringCAF extends CAF {
+
+    private String s;
+
+    public StringCAF(final String s) {
+        this.s = s;
+    }
+
+    @Override
+    public Closure thunkEnter(StgContext context) {
+        return Utils.jstringToString(null, s);
+    }
+
+    @Override
+    public void clear() {
+        this.s = null;
+    }
+}
diff --git a/tests/suite/trace-heap/run/TraceHeap1.stdout b/tests/suite/trace-heap/run/TraceHeap1.stdout
@@ -9,7 +9,7 @@ main_transformedString[_]
 x1[_] 'H'
 x1[_] 'e'
 x1[_] 'l'
-(: 'H' (: 'E' (: 'L' (sat$4[_] 2 (unpack$2[1] [] main20[2] 4544L)))))
+(: 'H' (: 'E' (: 'L' (sat$4[_] 2 (unpack$2[1] [] main20[2] 28672L)))))
 x1[_] 'l'
 x1[_] 'o'
 x1[_] ' '