a

app/Gyehoek/ANF/Syntax.hs

@@ -167,6 +167,8 @@ toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
   where
     anf x = toANF' x (pure . ExpVal)
 
+toANF' (Lam.ExpLet xs e) k = _
+
 toANF' e k = _
 
 toANF e = toANF' e (pure . ExpVal)
@@ -265,9 +267,12 @@ buildBlock n bb = QBE.Block n [] (is ^.. each) j
 lowerName :: Name -> QBE.Ident t
 lowerName = fromString . T.unpack
 
+lowerInt' = QBE.ValConst . QBE.CInt . fromIntegral
+
 lowerInt = QBE.ValConst . QBE.CInt
   . (Data.Bits..|. 2)
-  . (Data.Bits..<<. 2) . fromIntegral
+  . (Data.Bits..<<. 2)
+  . fromIntegral
 
 lowerVal
   :: forall es. (GenSym :> es)
@@ -298,7 +303,7 @@ lowerArithmetic r p = QBE.BinaryOp r bop x y
       PrimMul a b -> (QBE.Mul,a,b)
       _ -> _
 
-sizeofScm = 16
+sizeofScm = 8
 
 lowerCons
   :: (GenSym :> es)
@@ -315,7 +320,7 @@ lowerCons r car cdr e k = do
               Nothing
               [ QBE.Arg
                 (QBE.AbiBaseTy QBE.Long)
-                (QBE.ValConst (QBE.CInt sizeofScm)) ]
+                (QBE.ValConst (QBE.CInt (sizeofScm * 2))) ]
               []
             ]
     initialise r1 =
@@ -325,32 +330,53 @@ lowerCons r car cdr e k = do
       , QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
       ]
 
+smallIntHelper'
+  :: GenSym :> es
+  => QBE.Ident 'QBE.Temporary
+  -> QBE.BinaryOp
+  -> QBE.Val -> QBE.Val
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+smallIntHelper' r bop v1 v2 k = do
+  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
+         bop v1 v2 ]
+    <$> k (QBE.ValTemporary r)
+
 smallIntHelper
   :: GenSym :> es
-  => _
-  -> QBE.Val -> (QBE.Val -> Eff es BlockBuilder)
+  => QBE.BinaryOp
+  -> QBE.Val -> QBE.Val
+  -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
-smallIntHelper bop v k = do
+smallIntHelper bop a b k = do
   r <- gensym
-  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
-         bop v (QBE.ValConst (QBE.CInt 2)) ]
-    <$> k (QBE.ValTemporary r)
+  smallIntHelper' r bop a b k
+
+makeSmallInt'
+  :: forall es. (GenSym :> es)
+  => QBE.Ident 'QBE.Temporary
+  -> QBE.Val
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+makeSmallInt' r n k =
+  smallIntHelper QBE.Shl n (lowerInt' 2) \n' ->
+    smallIntHelper' r QBE.Add n' (lowerInt' 2) k
 
 makeSmallInt
   :: forall es. (GenSym :> es)
   => QBE.Val
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
-makeSmallInt n k =
-  smallIntHelper QBE.Shl n \n' ->
-    smallIntHelper QBE.And n' k
+makeSmallInt n k = do
+  r <- gensym
+  makeSmallInt' r n k
 
 getSmallInt
   :: forall es. (GenSym :> es)
   => QBE.Val
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
-getSmallInt = smallIntHelper QBE.Shr
+getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
 
 lowerWrite 
   :: forall es. (GenSym :> es)
@@ -365,6 +391,31 @@ lowerWrite r x e k =
        ]
     <$> k (QBE.ValTemporary (lowerName r))
 
+smallIntMask :: Integer
+smallIntMask = 2 ^ (sizeofScm * 8) - 2
+
+lowerCar
+  :: GenSym :> es
+  => Name -> QBE.Val -> _
+  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
+lowerCar r x e k = do
+  Emit [ QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long x
+       ]
+    <$> lower' e k
+
+lowerCdr
+  :: GenSym :> es
+  => Name -> QBE.Val -> Exp
+  -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
+lowerCdr r x e k = do
+  x1 <- gensym
+  Emit [ QBE.BinaryOp (x1 QBE.:= QBE.Long)
+         QBE.Add x (lowerInt' sizeofScm)
+       , QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long
+         (QBE.ValTemporary x1)
+       ]
+    <$> lower' e k
+
 lowerPrim 
   :: forall es. (GenSym :> es)
   => Name -> Prim Val -> Exp
@@ -372,19 +423,15 @@ lowerPrim
   -> Eff es BlockBuilder
 lowerPrim r p e k =
   telescope (lowerVal <$> p) \case
-    (preview binaryPrim -> Just (bop,a,b)) -> do
-      r1 <- gensym
-      r2 <- gensym
-      Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
-           , QBE.BinaryOp (r2 QBE.:= QBE.Long) QBE.And
-             (QBE.ValTemporary r1)
-             (QBE.ValConst (QBE.CInt 0xffff_ffff_ffff_fffd))
-           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.Or
-             (QBE.ValTemporary r2)
-             (QBE.ValConst (QBE.CInt 0b10))
-           ]
-        <$> lower' e k
+    (preview binaryPrim -> Just (bop,a,b)) ->
+      getSmallInt a \a' ->
+        getSmallInt b \b' ->
+          smallIntHelper bop a' b' \c ->
+            makeSmallInt' (lowerName r) c \_ ->
+              lower' e k
     PrimCons x y -> lowerCons r x y e k
+    PrimCar x -> lowerCar r x e k
+    PrimCdr x -> lowerCdr r x e k
     PrimWrite x -> lowerWrite r x e k
 
 lower'

flake.nix

@@ -43,9 +43,9 @@
                 gcc
                 qbe
                 haskellPackages.cabal-fmt
-                schemat
                 bdwgc
                 pkg-config
+                guile
               ];
             };
           };

play/a.c

@@ -0,0 +1,23 @@
+#include <stdio.h>
+#include <libguile/scm.h>
+
+#define BLAH (-1 >> 2 == -1) && (-4 >> 2 == -1) && (-5 >> 2 == -2) && (-8 >> 2 == -2)
+
+#if BLAH
+# define SCM_SRS(x, y)  ((x) >> (y))
+#else
+# define SCM_SRS(x, y)                                   \
+  ((x) < 0                                               \
+   ? -1 - (scm_t_signed_bits) (~(scm_t_bits)(x) >> (y))  \
+   : ((x) >> (y)))
+#endif
+
+int main () {
+  unsigned long mask = 0xfffffffffffffffe;
+  unsigned long x = (4 << 2) + 2;
+  unsigned long y = (2 << 2) + 2;
+  unsigned long z = ((x + y) >> 2) + 2;
+  printf ("BLAH: %d\n", BLAH);
+  printf ("%ld\n", sizeof(long));
+  printf ("%lx\n", (long) z >> 2);
+}

play/t.anf

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

play/t.s

@@ -3,7 +3,11 @@
 main:
 	pushq %rbp
 	movq %rsp, %rbp
-	movl $30, %edi
+	movl $16, %edi
+	callq GC_malloc
+	movq $18, (%rax)
+	movq $10, 8(%rax)
+	movl $26, %edi
 	callq scm_write
 	leave
 	ret

play/t.scm

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

play/t.ssa

@@ -1,9 +1,17 @@
 export
 function w $main () {
 @start
-    %.2 =l add 10, 18
-    %.3 =l and %.2, 18446744073709551613
-    %x0 =l or %.3, 2
-    %x1 =l call $scm_write (l %x0)
-    ret %x1
+    %x0 =l call $GC_malloc (l 16)
+    %.4 =l add %x0, 8
+    storel 18, %x0
+    storel 10, %.4
+    %.5 =l add %x0, 8
+    %x1 =l loadl %.5
+    %.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
 }

runtime/gyehoek.c

@@ -5,7 +5,7 @@ SCM scm_write (SCM x) {
   if (SCM_IMP (x)) {
     printf ("#<immediate %ld>\n", SCM_UNPACK (x) >> 2);
   } else {
-    printf ("#<heap object %lx>\n", SCM_UNPACK(x));
+    printf ("#<heap object 0x%016lx>\n", SCM_UNPACK (x));
   }
   return SCM_PACK(NULL);
 }

runtime/gyehoek.h

@@ -15,6 +15,10 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 #define SCM_NIMP(x) 		(!SCM_IMP (x))
 #define SCM_HEAP_OBJECT_P(x)    (SCM_NIMP (x))
 
+#define SCM_FALSE 0b00100
+#define SCM_TRUE  0b01100
+#define SCM_EOL   0b10100
+
 
 
 SCM scm_write (SCM);