string

app/Gyehoek/ANF/Syntax.hs

@@ -48,6 +48,8 @@ import Data.InvertibleGrammar.Base ((:-)((:-)))
 import qualified Gyehoek.Sexp
 import Control.Lens.Unsound
 import qualified Data.Bits
+import qualified GHC.IO.Encoding as T
+import qualified Data.Text.Encoding as T
 
 
 data Val
@@ -275,12 +277,36 @@ lowerInt = QBE.ValConst . QBE.CInt
   . fromIntegral
 
 lowerVal
-  :: forall es. (GenSym :> es)
+  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
   => Val
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
 
 lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
+
+lowerVal (ValLit (LitString s)) k = do
+  rawString <- gensym
+  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
+    alloc r rs len =
+      [ QBE.Call
+        (Just (r, QBE.AbiBaseTy QBE.Long))
+        (QBE.ValGlobal "scm_from_utf8_string")
+        Nothing
+        [ QBE.Arg (QBE.AbiBaseTy QBE.Long) (QBE.ValGlobal rs)
+        -- N.b. The C function declares this argument as size_t, which
+        -- /is/ long on my system.
+        , QBE.Arg (QBE.AbiBaseTy QBE.Long) (lowerInt' len)
+        ]
+        []
+      ]
+
 lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
 
@@ -303,6 +329,7 @@ lowerArithmetic r p = QBE.BinaryOp r bop x y
       PrimMul a b -> (QBE.Mul,a,b)
       _ -> _
 
+sizeofScm :: Int
 sizeofScm = 8
 
 lowerCons
@@ -417,7 +444,7 @@ lowerCdr r x e k = do
     <$> lower' e k
 
 lowerPrim 
-  :: forall es. (GenSym :> es)
+  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
   => Name -> Prim Val -> Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -435,7 +462,7 @@ lowerPrim r p e k =
     PrimWrite x -> lowerWrite r x e k
 
 lower'
-  :: forall es. (GenSym :> es)
+  :: forall es. (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
   => Exp
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
@@ -460,7 +487,11 @@ lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
 
 lower' _ k = _
 
-lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
+lower
+  :: (GenSym :> es, Writer (Vector QBE.DataDef) :> es)
+  => QBE.Ident QBE.Label
+  -> Exp
+  -> Eff es QBE.Block
 lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
 
 lowerProgram 
@@ -471,17 +502,17 @@ lowerProgram anfs =
     -- hack for dev convenience: if there's only one expression, let
     -- it be the entry point.
     [e] -> do
-      b <- lower "start" e
+      (b,dataDefs) <- runWriter . lower "start" $ e
       let f = wrapFunction @NonEmpty "main" [b]
-      pure $ QBE.Program [] [] [f]
+      pure $ QBE.Program [] (dataDefs ^.. each) [f]
     _ -> do
       let low e = do
             bl <- gensym' "b"
             fl <- gensym' "f"
             b <- lower bl e
             pure $ wrapFunction @NonEmpty fl [b]
-      fs <- traverse low anfs
-      pure $ QBE.Program [] [] (fs ^.. traversed)
+      (fs,dataDefs) <- runWriter $ traverse low anfs
+      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
 
 wrapFunction
   :: Foldable1 t