4 + 2 = 6

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.BinaryOp
-  -> QBE.Val -> (QBE.Val -> Eff es BlockBuilder)
+  -> 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)
+  smallIntHelper' r bop a b k
-         bop v (QBE.ValConst (QBE.CInt 2)) ]
+
-    <$> k (QBE.ValTemporary r)
+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 =
+makeSmallInt n k = do
-  smallIntHelper QBE.Shl n \n' ->
+  r <- gensym
-    smallIntHelper QBE.And n' k
+  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 `quot` 2))
+       , 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
+    (preview binaryPrim -> Just (bop,a,b)) ->
-      r1 <- gensym
+      getSmallInt a \a' ->
-      r2 <- gensym
+        getSmallInt b \b' ->
-      Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
+          smallIntHelper bop a' b' \c ->
-           , QBE.BinaryOp (r2 QBE.:= QBE.Long) QBE.And
+            makeSmallInt' (lowerName r) c \_ ->
-             (QBE.ValTemporary r1)
+              lower' e k
-             (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
     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,4 @@
 ;;; -*- mode:scheme -*-
 
-(let ((x0 (prim:+ 2 4)) (x1 (prim:write x0))) x1)
+(let ((x0 (prim:cons 4 2)) (x2 (prim:write x1)) (x1 (prim:car x0))) x2)
 

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 $18, %edi
 	callq scm_write
 	leave
 	ret

play/t.scm

@@ -1 +1,3 @@
-(prim:write (prim:+ 2 4))
+(let ((pair (prim:cons 4 2)))
+  (begin (prim:write (prim:car pair))
+         (prim:write (prim:cdr pair))))

play/t.ssa

@@ -1,9 +1,11 @@
 export
 function w $main () {
 @start
-    %.2 =l add 10, 18
+    %x0 =l call $GC_malloc (l 16)
-    %.3 =l and %.2, 18446744073709551613
+    %.3 =l add %x0, 8
-    %x0 =l or %.3, 2
+    storel 18, %x0
-    %x1 =l call $scm_write (l %x0)
+    storel 10, %.3
-    ret %x1
+    %x1 =l loadl %x0
+    %x2 =l call $scm_write (l %x1)
+    ret %x2
 }

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);
 }