reuse string lits

app/Gyehoek/ANF/Syntax.hs

@@ -50,6 +50,9 @@ import Control.Lens.Unsound
 import qualified Data.Bits
 import qualified GHC.IO.Encoding as T
 import qualified Data.Text.Encoding as T
+import Data.HashMap.Strict (HashMap)
+import Effectful.State.Static.Local
+import qualified Data.HashMap.Strict as HM
 
 
 data Val
@@ -277,18 +280,23 @@ lowerInt = QBE.ValConst . QBE.CInt
   . fromIntegral
 
 lowerString
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Text -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerString s k = do
-  rawString <- gensym
+  let len = lengthOf each $ T.encodeUtf8 s
+  rawString <- getRawString
   r <- gensym
-  let bs = T.encodeUtf8 s
-      len = lengthOf each bs
-  tell . pure $
-    QBE.DataDef [] rawString Nothing
-      [QBE.FieldExtTy QBE.Byte [QBE.String bs]]
   Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
   where
+    -- getRawString
+    --   :: forall es. (GenSym :> es, State StringLiterals :> es)
+    --   => Eff es _
+    getRawString = do
+      x <- get
+      case x ^. at s of
+        Just s' -> pure s'
+        Nothing -> do r <- gensym
+                      state \lits -> (r, HM.insert s r lits)
     alloc r rs len =
       [ QBE.Call
         (Just (r, QBE.AbiBaseTy QBE.Long))
@@ -302,8 +310,10 @@ lowerString s k = do
         []
       ]
 
+type StringLiterals = HashMap Text (QBE.Ident QBE.Global)
+
 lowerVal
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Val
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -353,7 +363,7 @@ sizeofScm :: Integral a => a
 sizeofScm = 8
 
 lowerCons
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> QBE.Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -442,7 +452,7 @@ smallIntMask :: Integer
 smallIntMask = 2 ^ (sizeofScm * 8) - 2
 
 lowerCar
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> _
   -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCar r x e k = do
@@ -451,7 +461,7 @@ lowerCar r x e k = do
     <$> lower' e k
 
 lowerCdr
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => Name -> QBE.Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
 lowerCdr r x e k = do
@@ -472,7 +482,7 @@ lowerNewline r k =
     <$> k (QBE.ValTemporary (lowerName r))
 
 lowerPrim 
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Name -> Prim Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -491,7 +501,7 @@ lowerPrim r p e k =
     PrimNewline -> lowerNewline r k
 
 lower'
-  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: forall es. (GenSym :> es, State StringLiterals :> es)
   => Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -517,12 +527,17 @@ lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
 lower' _ k = _
 
 lower
-  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  :: (GenSym :> es, State StringLiterals :> es)
   => QBE.Ident QBE.Label
   -> Exp
   -> Eff es QBE.Block
 lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
 
+lowerStringLiterals =
+  ifoldMapOf itraversed \s v ->
+    [ QBE.DataDef [] v Nothing
+      [QBE.FieldExtTy QBE.Byte [QBE.String (T.encodeUtf8 s)]]]
+
 lowerProgram 
   :: (GenSym :> es, Traversable t)
   => t Exp -> Eff es QBE.Program
@@ -531,17 +546,18 @@ lowerProgram anfs =
     -- hack for dev convenience: if there's only one expression, let
     -- it be the entry point.
     [e] -> do
-      (b,dataDefs) <- runWriter . lower "start" $ e
+      (b,stringLits) <- runState mempty . lower "start" $ e
       let f = wrapFunction @NonEmpty "main" [b]
-      pure $ QBE.Program [] (dataDefs ^.. each) [f]
+          dataDefs = lowerStringLiterals stringLits
+      pure $ QBE.Program [] dataDefs [f]
     _ -> do
       let low e = do
             bl <- gensym' "b"
             fl <- gensym' "f"
             b <- lower bl e
             pure $ wrapFunction @NonEmpty fl [b]
-      (fs,dataDefs) <- runWriter $ traverse low anfs
-      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
+      (fs,stringLits) <- runState mempty $ traverse low anfs
+      pure $ QBE.Program [] (lowerStringLiterals stringLits) (fs ^.. traversed)
 
 wrapFunction
   :: Foldable1 t

runtime/src/scm.rs

@@ -193,7 +193,7 @@ impl std::hash::Hash for Symbol {
     }
 }
 
-pub fn make_symbol_off_heap (name : scm_bits) -> Symbol {
+fn make_symbol_off_heap (name : scm_bits) -> Symbol {
     Symbol ([ tc7_symbol, name ])
 }
 

runtime/test.rs

@@ -1,5 +0,0 @@
-use gyehoek::scm::*;
-
-pub fn main () {
-
-}