small

app/Gyehoek/ANF.hs

@@ -237,22 +237,40 @@ lowerVal (ValLit (LitInt n)) k =
 lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
 
-lowerBinaryOp :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
+binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
-lowerBinaryOp r p = QBE.BinaryOp r bop x y
+binaryPrim = prism' up down where
+  up (bop,a,b) = case bop of
+    QBE.Add -> _
+    QBE.Mul -> _
+    _ -> _
+  down = \case
+    PrimAdd a b -> Just (QBE.Add,a,b)
+    PrimMul a b -> Just (QBE.Mul,a,b)
+    _ -> Nothing
+
+lowerArithmetic :: QBE.Assignment -> Prim QBE.Val -> QBE.Inst
+lowerArithmetic r p = QBE.BinaryOp r bop x y
   where
     (bop,x,y) = case p of
       PrimAdd a b -> (QBE.Add,a,b)
       PrimMul a b -> (QBE.Mul,a,b)
       _ -> _
 
--- lowerPrim 
+lowerCons :: QBE.Val -> QBE.Val -> _
---   :: forall es. (GenSym :> es)
+lowerCons = _
---   => Prim Val
+
---   -> (QBE.Val -> Eff es BlockBuilder)
+lowerPrim 
---   -> Eff es BlockBuilder
+  :: forall es. (GenSym :> es)
--- lowerPrim p k = telescope (lowerVal <$> p) \p' -> do
+  => _
---   Emit [ lowerBinaryOp (r QBE.:= QBE.Long) p' ]
+  -> _
---     <$> k (QBE.ValTemporary r)
+  -> _
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+lowerPrim r p e k =
+  telescope (lowerVal <$> p) \case
+    (preview binaryPrim -> Just (bop,a,b)) ->
+      Emit [ QBE.BinaryOp r bop a b ] <$> lower' e k
+    PrimCons x y -> _
 
 lower'
   :: forall es. (GenSym :> es)
@@ -262,13 +280,10 @@ lower'
 
 lower' (ExpVal v) k = lowerVal v k
 
-lower' (ExpLetPrim r p e) k =
+lower' (ExpLetPrim r p e) k = lowerPrim r p e k
-  telescope (lowerVal <$> p) \p' -> do
-    Emit [ lowerBinaryOp (lowerName r QBE.:= QBE.Long) p' ]
-      <$> lower' e k
 
 lower' (ExpLetApply r f xs e) k =
-  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') -> do
+  telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
     Emit [ QBE.Call
             (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
             f'

app/Gyehoek/Syntax.hs

@@ -23,6 +23,7 @@ data Prim e
   | PrimSub e e
   | PrimMul e e
   | PrimDiv e e
+  | PrimCons e e
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
 instance Each (Prim e) (Prim e') e e'
@@ -47,10 +48,11 @@ data Exp
 
 instance SexpIso a => SexpIso (Prim a) where
   sexpIso = match
-    $ With (. binop "prim-+")
+    $ With (. binop "prim:+")
-    $ With (. binop "prim--")
+    $ With (. binop "prim:-")
-    $ With (. binop "prim-*")
+    $ With (. binop "prim:*")
-    $ With (. binop "prim-/")
+    $ With (. binop "prim:/")
+    $ With (. binop "prim:cons")
     $ End
     where
       binop s = list $ el (sym s) >>> el sexpIso >>> el sexpIso

bdwgc.nix

@@ -0,0 +1,18 @@
+{ cmake
+, stdenv
+, fetchFromGitHub
+}:
+
+stdenv.mkDerivation (finalAttrs: {
+  pname = "bdwgc";
+  version = "8.2.12";
+  src = fetchFromGitHub {
+    owner = "bdwgc";
+    repo = "bdwgc";
+    tag = "v${finalAttrs.version}";
+    hash = "sha256-5yeAB5Y92YjOutwRXBJkMxoOLkmzmqIJs4PirKX89fE=";
+  };
+  nativeBuildInputs = [
+    cmake
+  ];
+})

flake.nix

@@ -14,6 +14,9 @@
 
       overlays = [
         haskellNix.overlay
+        (final: prev: {
+          bdwgc = final.callPackage ./bdwgc.nix {};
+        })
         (final: prev: {
           # haskellPackages = prev.haskellPackages.override {
           #   qbe = final.haskell-nix.project' {
@@ -72,6 +75,7 @@
         hf.packages.${system} // {
           default = hf.packages.${system}."gyehoek:exe:gyehoek";
           runtime = pkgs.callPackage ./runtime {};
+          inherit (pkgs) bdwgc;
         });
 
       devShells = each-system