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
+      (fs,dataDefs) <- runWriter $ traverse low anfs
-      pure $ QBE.Program [] [] (fs ^.. traversed)
+      pure $ QBE.Program [] (dataDefs ^.. each) (fs ^.. traversed)
 
 wrapFunction
   :: Foldable1 t

app/Gyehoek/Scheme/Syntax.hs

@@ -38,6 +38,7 @@ data Lit
   = LitInt Int
   | LitNil
   | LitBool Bool
+  | LitString Text
   deriving (Show, Generic)
 
 data Define
@@ -83,6 +84,7 @@ instance SexpIso Lit where
     $ With (. sexpIso)
     $ With (. sym "nil")
     $ With (. sexpIso)
+    $ With (. sexpIso)
     $ End
 
 instance SexpIso Define where

cabal.project

@@ -3,5 +3,5 @@ packages: *.cabal
 source-repository-package
     type: git
     location: https://git.deertopia.net/msyds/qbe-hs.git
-    tag: ab7cc053a4d58fde841e910f251b8e48b54466ad
+    tag: 64be0096355a8fd23cc1a4910ed5c8e6075aeca9
-    --sha256: 0n2jqr6vymlyr0gwzbv3cljhqxnzcq1pzf7m92b16jalkymbcwgy
+    --sha256: 0x507fmpyzyvg3f27wss94d7fkrbv6r05jknlphgyi53pscazr9r

example/ascii-string-literal.anf

@@ -0,0 +1,4 @@
+;;; -*- mode:scheme -*-
+
+(let ((x0 (prim:write "wawa"))) x0)
+

example/ascii-string-literal.s

@@ -0,0 +1,23 @@
+.data
+.balign 8
+.1:
+	.ascii "wawa"
+/* end data */
+
+.text
+.globl main
+main:
+	pushq %rbp
+	movq %rsp, %rbp
+	movl $4, %esi
+	leaq .1(%rip), %rdi
+	callq scm_from_utf8_string
+	movq %rax, %rdi
+	callq scm_write
+	leave
+	ret
+.type main, @function
+.size main, .-main
+/* end function main */
+
+.section .note.GNU-stack,"",@progbits

example/ascii-string-literal.scm

@@ -0,0 +1 @@
+(prim:write "wawa")

example/ascii-string-literal.ssa

@@ -0,0 +1,10 @@
+
+data $.1 =
+{b "wawa"}
+export
+function w $main () {
+@start
+    %.2 =l call $scm_from_utf8_string (l $.1, l 4)
+    %x0 =l call $scm_write (l %.2)
+    ret %x0
+}

example/string-literal.anf

@@ -0,0 +1,4 @@
+;;; -*- mode:scheme -*-
+
+(let ((x0 (prim:write "안녕하세요"))) x0)
+

example/string-literal.s

@@ -0,0 +1,23 @@
+.data
+.balign 8
+.1:
+	.ascii "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"
+/* end data */
+
+.text
+.globl main
+main:
+	pushq %rbp
+	movq %rsp, %rbp
+	movl $15, %esi
+	leaq .1(%rip), %rdi
+	callq scm_from_utf8_string
+	movq %rax, %rdi
+	callq scm_write
+	leave
+	ret
+.type main, @function
+.size main, .-main
+/* end function main */
+
+.section .note.GNU-stack,"",@progbits

example/string-literal.scm

@@ -0,0 +1 @@
+(prim:write "안녕하세요")

example/string-literal.ssa

@@ -0,0 +1,10 @@
+
+data $.1 =
+{b "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"}
+export
+function w $main () {
+@start
+    %.2 =l call $scm_from_utf8_string (l $.1, l 15)
+    %x0 =l call $scm_write (l %.2)
+    ret %x0
+}

play/string.anf

@@ -0,0 +1,4 @@
+;;; -*- mode:scheme -*-
+
+(let ((x0 (prim:write "abc"))) x0)
+

play/string.s

@@ -0,0 +1,23 @@
+.data
+.balign 8
+.1:
+	.ascii "abc"
+/* end data */
+
+.text
+.globl main
+main:
+	pushq %rbp
+	movq %rsp, %rbp
+	movl $3, %esi
+	leaq .1(%rip), %rdi
+	callq scm_from_utf8_string
+	movq %rax, %rdi
+	callq scm_write
+	leave
+	ret
+.type main, @function
+.size main, .-main
+/* end function main */
+
+.section .note.GNU-stack,"",@progbits

play/string.scm

@@ -0,0 +1 @@
+(prim:write "abc")

play/string.ssa

@@ -0,0 +1,10 @@
+
+data $.1 =
+{b "abc"}
+export
+function w $main () {
+@start
+    %.2 =l call $scm_from_utf8_string (l $.1, l 3)
+    %x0 =l call $scm_write (l %.2)
+    ret %x0
+}

play/t.anf

@@ -1,4 +1,4 @@
 ;;; -*- mode:scheme -*-
 
-(let ((x0 (prim:cons 4 2)) (x1 (prim:cdr x0)) (x2 (prim:* 3 x1)) (x3 (prim:write x2))) x3)
+(let ((x0 (prim:cons 4 2)) (x1 (prim:write x0))) x1)
 

play/t.s

@@ -5,9 +5,9 @@ main:
 	movq %rsp, %rbp
 	movl $16, %edi
 	callq GC_malloc
-	movq $18, (%rax)
+	movq %rax, %rdi
-	movq $10, 8(%rax)
+	movq $18, (%rdi)
-	movl $26, %edi
+	movq $10, 8(%rdi)
 	callq scm_write
 	leave
 	ret

play/t.scm

@@ -1,2 +1 @@
-(prim:write (prim:* 3
+(prim:write (prim:cons 4 2))
-                    (prim:cdr (prim:cons 4 2))))

play/t.ssa

@@ -2,16 +2,9 @@ export
 function w $main () {
 @start
     %x0 =l call $GC_malloc (l 16)
-    %.4 =l add %x0, 8
+    %.2 =l add %x0, 8
     storel 18, %x0
-    storel 10, %.4
+    storel 10, %.2
-    %.5 =l add %x0, 8
+    %x1 =l call $scm_write (l %x0)
-    %x1 =l loadl %.5
+    ret %x1
-    %.6 =l shr 14, 2
-    %.7 =l shr %x1, 2
-    %.8 =l mul %.6, %.7
-    %.9 =l shl %.8, 2
-    %x2 =l add %.9, 2
-    %x3 =l call $scm_write (l %x2)
-    ret %x3
 }

play/wtf.s

@@ -0,0 +1,31 @@
+.data
+.balign 8
+fstr:
+	.ascii "%s"
+	.byte 0
+/* end data */
+
+.data
+.balign 8
+str:
+	.ascii "안녕하세요"
+	.byte 0
+/* end data */
+
+.text
+.globl main
+main:
+	pushq %rbp
+	movq %rsp, %rbp
+	leaq str(%rip), %rsi
+	leaq fstr(%rip), %rdi
+	movl $0, %eax
+	callq printf
+	movl $0, %eax
+	leave
+	ret
+.type main, @function
+.size main, .-main
+/* end function main */
+
+.section .note.GNU-stack,"",@progbits

play/wtf.ssa

@@ -0,0 +1,8 @@
+data $fstr = { b "%s", b 0 }
+data $str = { b "안녕하세요", b 0 }
+
+export function w $main () {
+@start
+	call $printf (l $fstr, ..., l $str)
+	ret 0
+}

runtime/gyehoek.c

@@ -2,20 +2,54 @@
 #include <gc.h>
 #include "gyehoek.h"
 
+
+
+const long scm_tc3_cons = 0;
+
+const long scm_tc7_obarray = 0x55;
+const long scm_tc7_symbol = 0x05;
+const long scm_tc7_string = 0x15;
+
+
+
 SCM scm_newline () {
   putc ('\n', stdout);
   return SCM_PACK(NULL);
 }
 
+static void scm_write_string (SCM x) {
+  const size_t len = SCM_CELL_WORD (x, 1);
+  const char *s = (const char *) SCM_UNPACK_POINTER (SCM_CELL_OBJECT (x, 2));
+  /* FIXME: this is a very naïve implementation with no escaping. */
+  printf ("some unrelated unicode lol: %s\n", "왜 하냐??");
+  printf ("\"%.*s\"", (int) len, s);
+}
+
 SCM scm_write (SCM x) {
   if (SCM_IMP (x)) {
     printf ("%ld", SCM_UNPACK (x) >> 2);
+  } else if (SCM_CONSP (x)) {
+    printf ("(");
+    scm_write (scm_car (x));
+    printf (" . ");
+    scm_write (scm_cdr (x));
+    printf (")");
+  } else if (SCM_STRINGP (x)) {
+    scm_write_string (x);
   } else {
     printf ("#<heap object 0x%016lx>", SCM_UNPACK (x));
   }
   return SCM_PACK(NULL);
 }
 
+SCM scm_car (SCM x) {
+  return SCM_CELL_OBJECT (x, 0);
+}
+
+SCM scm_cdr (SCM x) {
+  return SCM_CELL_OBJECT (x, 1);
+}
+
 SCM scm_words (scm_t_bits word_0, uint32_t n_words) {
   scm_t_bits *r = GC_malloc (n_words * sizeof (scm_t_bits));
   r[0] = word_0;
@@ -24,11 +58,18 @@ SCM scm_words (scm_t_bits word_0, uint32_t n_words) {
 
 SCM scm_from_utf8_string (const char *str, size_t len) {
   SCM r = scm_words (scm_tc7_string, 3);
-  const char *s = GC_malloc (len);
   SCM_SET_CELL_WORD (r, 1, len);
-  SCM_SET_CELL_WORD (r, 2, s);
+  SCM_SET_CELL_WORD (r, 2, str);
+  printf ("str: %p\n", str);
   return r;
 }
 
-SCM scm_from_utf8_symbol (const char *s) {
+SCM scm_from_utf8_symbol (const char *s, size_t len) {
+}
+
+SCM scm_cons (SCM car, SCM cdr) {
+  scm_t_bits *r = GC_malloc (2 * sizeof (scm_t_bits));
+  r[0] = SCM_UNPACK (car);
+  r[1] = SCM_UNPACK (cdr);
+  return SCM_PACK (r);
 }

runtime/gyehoek.h

@@ -1,6 +1,7 @@
 #ifndef GYEHOEK_H
 #define GYEHOEK_H
 
+#include <stddef.h>
 #include <stdint.h>
 
 
@@ -38,7 +39,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
    Guile also known as a cons-cell): This is done by first checking that
    the SCM variable holds a heap object, and second, by checking that
    tc1==0 holds for the SCM_CELL_TYPE of the SCM variable.  */
-#define SCM_I_CONSP(x)  (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
+#define SCM_CONSP(x)  (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))
 
 
 
@@ -49,7 +50,12 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 #define SCM_ITAG3(x) (7 & SCM_UNPACK (x))
 #define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x))
 
-#define scm_tc3_cons 0
+/* #define scm_tc3_cons 0 */
+extern const long scm_tc3_cons;
+
+SCM scm_cons (SCM car, SCM cdr);
+SCM scm_car (SCM x);
+SCM scm_cdr (SCM x);
 
 
 
@@ -64,22 +70,29 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 #define SCM_SET_CELL_WORD(x, n, v)  \
   (SCM_SET_CELL_OBJECT ((x), (n), SCM_PACK (v)))
 
-#define SCM_CELL_TYPE(x) SCM_CELL_WORD (x)
+#define SCM_CELL_TYPE(x) SCM_CELL_WORD (x, 0)
 #define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x))
 #define SCM_HAS_HEAP_TYPE(x, type, tag)         \
   (SCM_NIMP (x) && type (x) == (tag))
 #define SCM_HAS_TYP7(x, tag)    (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
 
-#define scm_tc7_obarray 0x55
+extern const long scm_tc7_obarray;
-#define scm_tc7_symbol 0x05
+extern const long scm_tc7_symbol;
-#define scm_tc7_string 0x15
+extern const long scm_tc7_string;
+
+
+
+#define SCM_STRINGP(x) (SCM_TYP7 (x) == scm_tc7_string)
 
 
 
 SCM scm_words (scm_t_bits word_0, uint32_t n_words);
 
-/* Construct a symbol from a UTF-8 string. */
+/* Construct a Scheme string. */
-SCM scm_from_utf8 (const char *);
+SCM scm_from_utf8_string (const char *str, size_t len);
+
+/* Intern a symbol with a UTF-8 string name. */
+SCM scm_from_utf8_symbol (const char *s, size_t len);