4 + 2 = 6

2026-05-16 01:17:14 -06:00
parent 0bb66acae0
commit 466e2a38a9
10 changed files with 113 additions and 35 deletions
--- a/app/Gyehoek/ANF/Syntax.hs
+++ b/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 `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
-      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'
--- a/flake.nix
+++ b/flake.nix
@@ -43,9 +43,9 @@
                gcc
                qbe
                haskellPackages.cabal-fmt
-                schemat
                bdwgc
                pkg-config
+                guile
              ];
            };
          };
--- a/play/a.c
+++ b/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);
+}
--- a/play/a.out
+++ b/play/a.out
--- a/play/t
+++ b/play/t
--- a/play/t.anf
+++ b/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)

--- a/play/t.s
+++ b/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
--- a/play/t.scm
+++ b/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))))
--- a/play/t.ssa
+++ b/play/t.ssa
@@ -1,9 +1,11 @@
 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)
+    %.3 =l add %x0, 8
+    storel 18, %x0
+    storel 10, %.3
+    %x1 =l loadl %x0
+    %x2 =l call $scm_write (l %x1)
+    ret %x2
 }
--- a/runtime/gyehoek.c
+++ b/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);
 }