diff --git a/app/Gyehoek/ANF/Syntax.hs b/app/Gyehoek/ANF/Syntax.hs index 869b12e..1ddd875 100644 --- a/app/Gyehoek/ANF/Syntax.hs +++ b/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 diff --git a/runtime/src/scm.rs b/runtime/src/scm.rs index 374f636..1c39ca1 100644 --- a/runtime/src/scm.rs +++ b/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 ]) } diff --git a/runtime/test.rs b/runtime/test.rs deleted file mode 100644 index 0343983..0000000 --- a/runtime/test.rs +++ /dev/null @@ -1,5 +0,0 @@ -use gyehoek::scm::*; - -pub fn main () { - -}