big

app/Gyehoek/ANF.hs

@@ -42,6 +42,7 @@ import Data.InvertibleGrammar.Base qualified as IG
 import Data.InvertibleGrammar.Base ((:-)((:-)))
 import qualified Gyehoek.Sexp
 import Control.Lens.Unsound
+import qualified Data.Bits
 
 
 data Val
@@ -157,6 +158,10 @@ toANF' (Lam.ExpApply f xs) k =
     r <- gensym
     ExpLetApply r f' xs' <$> k (ValVar r)
 
+toANF' (Lam.ExpBegin xs) k = ExpBegin <$> traverse anf xs
+  where
+    anf x = toANF' x (pure . ExpVal)
+
 toANF' e k = _
 
 toANF e = toANF' e (pure . ExpVal)
@@ -172,6 +177,17 @@ expr =
        (Lam.ExpLit (LitInt 3))))
     (Lam.ExpLit (LitInt 4)))
 
+expr2 =
+  Lam.ExpBegin
+    [ Lam.ExpPrim
+      (PrimWrite
+       (Lam.ExpPrim
+         (PrimCons
+          (Lam.ExpLit (LitInt 2))
+          (Lam.ExpLit (LitInt 3)))))
+    , Lam.ExpPrim (PrimWrite (Lam.ExpLit (LitInt 4)))
+    ]
+
 
 
 instance Semigroup QBE.Program where
@@ -185,14 +201,23 @@ instance Monoid QBE.Program where
 funcdef
   :: QBE.Ident QBE.Global
   -> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
-funcdef name ps = QBE.FuncDef mempty Nothing name Nothing ps QBE.NoVariadic
+funcdef name ps =
+  QBE.FuncDef
+  mempty
+  (Just (QBE.AbiBaseTy QBE.Long))
+  name Nothing ps QBE.NoVariadic
 
 prims :: QBE.Program
-prims = QBE.Program mempty mempty primfns where
+prims = QBE.Program primtys mempty primfns where
-  primfns = [ mkArith "plus" QBE.Add
+  primtys =
-            , mkArith "star" QBE.Mul
+    [ QBE.TypeDef "scm" Nothing
-            , mkArith "_" QBE.Sub
+      [ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
-            , mkArith "slash" (QBE.Div QBE.Signed)
+    ]
+  primfns = [ -- write
+            -- , mkArith "plus" QBE.Add
+            -- , mkArith "star" QBE.Mul
+            -- , mkArith "_" QBE.Sub
+            -- , mkArith "slash" (QBE.Div QBE.Signed)
             ]
   mkArith name bop =
     funcdef name
@@ -211,6 +236,10 @@ data BlockBuilder
   | Exit QBE.Jump
   deriving (Show)
 
+instance Semigroup BlockBuilder where
+  Emit a as <> bs = Emit a (as <> bs)
+  Exit _ <> bs = bs
+
 instance Each BlockBuilder BlockBuilder QBE.Inst QBE.Inst where
   each k (Emit is bb) = Emit <$> traverse k is <*> each k bb
   each k (Exit j) = pure (Exit j)
@@ -226,14 +255,17 @@ buildBlock n bb = QBE.Block n [] (is ^.. each) j
 lowerName :: Name -> QBE.Ident t
 lowerName = fromString . T.unpack
 
+lowerInt = QBE.ValConst . QBE.CInt
+  . (Data.Bits..|. 2)
+  . (Data.Bits..<<. 2) . fromIntegral
+
 lowerVal
   :: forall es. (GenSym :> es)
   => Val
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
 
-lowerVal (ValLit (LitInt n)) k =
+lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
-  k . QBE.ValConst . QBE.CInt . fromIntegral $ n
 lowerVal (ValLit _) k = error "todo"
 lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
 
@@ -256,21 +288,89 @@ lowerArithmetic r p = QBE.BinaryOp r bop x y
       PrimMul a b -> (QBE.Mul,a,b)
       _ -> _
 
-lowerCons :: QBE.Val -> QBE.Val -> _
+sizeofScm = 16
-lowerCons = _
+
+lowerCons
+  :: (GenSym :> es)
+  => Name -> QBE.Val -> QBE.Val -> Exp
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+lowerCons r car cdr e k = do
+  r1 <- gensym
+  Emit (alloc <> initialise r1) <$> lower' e k
+  where
+    alloc = [ QBE.Call
+              (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
+              (QBE.ValGlobal "GC_malloc")
+              Nothing
+              [ QBE.Arg
+                (QBE.AbiBaseTy QBE.Long)
+                (QBE.ValConst (QBE.CInt sizeofScm)) ]
+              []
+            ]
+    initialise r1 =
+      [ QBE.BinaryOp (r1 QBE.:= QBE.Long) QBE.Add
+        (QBE.ValTemporary (lowerName r)) (QBE.ValConst (QBE.CInt 8))
+      , QBE.Store (QBE.BaseTy QBE.Long) car (QBE.ValTemporary (lowerName r))
+      , QBE.Store (QBE.BaseTy QBE.Long) cdr (QBE.ValTemporary r1)
+      ]
+
+smallIntHelper
+  :: GenSym :> es
+  => _
+  -> QBE.Val -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+smallIntHelper bop v k = do
+  r <- gensym
+  Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
+         bop v (QBE.ValConst (QBE.CInt 2)) ]
+    <$> k (QBE.ValTemporary r)
+
+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
+
+getSmallInt
+  :: forall es. (GenSym :> es)
+  => QBE.Val
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+getSmallInt = smallIntHelper QBE.Shr
+
+lowerWrite 
+  :: forall es. (GenSym :> es)
+  => Name -> QBE.Val -> Exp
+  -> (QBE.Val -> Eff es BlockBuilder)
+  -> Eff es BlockBuilder
+lowerWrite r x e k =
+  Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
+         (QBE.ValGlobal "scm_write") Nothing
+         [QBE.Arg (QBE.AbiBaseTy QBE.Long) x]
+         []
+       ]
+    <$> k (QBE.ValTemporary (lowerName r))
 
 lowerPrim 
   :: forall es. (GenSym :> es)
-  => _
+  => Name -> Prim Val -> Exp
-  -> _
-  -> _
   -> (QBE.Val -> Eff es BlockBuilder)
   -> Eff es BlockBuilder
 lowerPrim r p e k =
   telescope (lowerVal <$> p) \case
-    (preview binaryPrim -> Just (bop,a,b)) ->
+    (preview binaryPrim -> Just (bop,a,b)) -> do
-      Emit [ QBE.BinaryOp r bop a b ] <$> lower' e k
+      r1 <- gensym
-    PrimCons x y -> _
+      Emit [ QBE.BinaryOp (r1 QBE.:= QBE.Long) bop a b
+           , QBE.BinaryOp (lowerName r QBE.:= QBE.Long) QBE.And
+             (QBE.ValTemporary r1) (QBE.ValConst (QBE.CInt 0b10))
+           ]
+        <$> lower' e k
+    PrimCons x y -> lowerCons r x y e k
+    PrimWrite x -> lowerWrite r x e k
 
 lower'
   :: forall es. (GenSym :> es)
@@ -293,13 +393,16 @@ lower' (ExpLetApply r f xs e) k =
           ]
       <$> lower' e k
 
+lower' (ExpBegin (x:xs)) k = fold1 <$> traverse low (x:|xs)
+  where low e = lower' @es e (pure . Exit . QBE.Ret . Just)
+
 lower' _ k = _
 
 lower :: GenSym :> es => QBE.Ident QBE.Label -> Exp -> Eff es QBE.Block
 lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
 
 wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
-wrapProgram bs = QBE.Program [] [] [main] where
+wrapProgram bs = prims <> QBE.Program [] [] [main] where
   main = QBE.FuncDef [QBE.Export]
     (Just (QBE.AbiBaseTy QBE.Word))
     "main" Nothing [] QBE.NoVariadic (toNonEmpty bs)

app/Gyehoek/QBE.hs

@@ -9,6 +9,7 @@ module Gyehoek.QBE
   ( module QBE
   , render
   , fn
+  , writeTo
   )
   where
 
@@ -24,8 +25,12 @@ import Text.Megaparsec.Char
 import Language.Haskell.TH qualified as TH
 import Language.Haskell.TH.Quote
 import Data.Kind (Type)
+import qualified Data.Text.IO as TIO
 
 
+writeTo :: FilePath -> Text -> IO ()
+writeTo = TIO.writeFile
+
 render :: Pretty a => a -> Text
 render = renderStrict . layoutPretty defaultLayoutOptions . pretty
 

app/Gyehoek/Syntax.hs

@@ -24,6 +24,12 @@ data Prim e
   | PrimMul e e
   | PrimDiv e e
   | PrimCons e e
+  | PrimCar e
+  | PrimCdr e
+  | PrimImmediateP e
+  | PrimConsP e
+  | PrimIntegerP e
+  | PrimWrite e
   deriving (Show, Generic, Functor, Foldable, Traversable)
 
 instance Each (Prim e) (Prim e') e e'
@@ -36,10 +42,10 @@ data Lit
 
 data Exp
   = ExpLet (NonEmpty (Name, Exp)) Exp
-  | ExpApply Exp (List Exp)
+  | ExpPrim (Prim Exp)
   | ExpBegin (List Exp)
   | ExpLit Lit
-  | ExpPrim (Prim Exp)
+  | ExpApply Exp (List Exp)
   | ExpLambda (List Name) Exp
   | ExpVar Name
   deriving (Show, Generic)
@@ -48,14 +54,22 @@ data Exp
 
 instance SexpIso a => SexpIso (Prim a) where
   sexpIso = match
-    $ With (. binop "prim:+")
+    $ With (. binop "+")
-    $ With (. binop "prim:-")
+    $ With (. binop "-")
-    $ With (. binop "prim:*")
+    $ With (. binop "*")
-    $ With (. binop "prim:/")
+    $ With (. binop "/")
-    $ With (. binop "prim:cons")
+    $ With (. binop "cons")
+    $ With (. unop "car")
+    $ With (. unop "cdr")
+    $ With (. unop "immediate?")
+    $ With (. unop "cons?")
+    $ With (. unop "integer?")
+    $ With (. unop "write")
     $ End
     where
-      binop s = list $ el (sym s) >>> el sexpIso >>> el sexpIso
+      primname = ("prim:" <>)
+      unop s = list $ el (sym (primname s)) >>> el sexpIso
+      binop s = list $ el (sym (primname s)) >>> el sexpIso >>> el sexpIso
 
 instance SexpIso Lit where
   sexpIso = match
@@ -67,10 +81,10 @@ instance SexpIso Lit where
 instance SexpIso Exp where
   sexpIso = match
     $ With (. Gyehoek.Sexp.let_ symbol sexpIso sexpIso)
-    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
+    $ With (. sexpIso)
     $ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
     $ With (. sexpIso)
-    $ With (. sexpIso)
+    $ With (\app -> app . list (el sexpIso >>> rest sexpIso))
     $ With (. lam)
     $ With (. symbol)
     $ End

flake.nix

@@ -44,6 +44,8 @@
                 qbe
                 haskellPackages.cabal-fmt
                 schemat
+                bdwgc
+                pkg-config
               ];
             };
           };

play/t.ssa

@@ -0,0 +1,12 @@
+type :scm = {l 2}
+export
+function w $main () {
+@start
+    %x0 =l call $GC_malloc (l 16)
+    %.3 =l add %x0, 8
+    storel 10, %x0
+    storel 14, %.3
+    %x1 =l call $scm_write (l %x0)
+    %x2 =l call $scm_write (l 18)
+    ret %x2
+}

runtime/default.nix

@@ -1,6 +1,6 @@
 { stdenv
 , callPackage
-, bdwgc ? callPackage ./bdwgc.nix {}
+, bdwgc ? callPackage ../bdwgc.nix {}
 }:
 
 stdenv.mkDerivation {

runtime/gyehoek.c

@@ -1,5 +1,11 @@
 #include <stdio.h>
+#include "gyehoek.h"
 
-int blah () {
+SCM scm_write (SCM x) {
-  puts ("aaa");
+  if (SCM_IMP (x)) {
+    printf ("#<immediate %ld>\n", SCM_UNPACK (x));
+  } else {
+    printf ("#<heap object %ld>\n", SCM_UNPACK(x));
+  }
+  return SCM_PACK(NULL);
 }

runtime/gyehoek.h

@@ -0,0 +1,23 @@
+#ifndef GYEHOEK_H
+#define GYEHOEK_H
+
+#include <stdint.h>
+
+
+
+typedef uintptr_t scm_t_bits;
+
+typedef union SCM { struct { scm_t_bits n; } n; } SCM;
+
+#define SCM_UNPACK(x) ((x).n.n)
+#define SCM_PACK(x) ((SCM) { { (scm_t_bits) (x) } })
+#define SCM_IMP(x) 		(6 & SCM_UNPACK (x))
+#define SCM_NIMP(x) 		(!SCM_IMP (x))
+#define SCM_HEAP_OBJECT_P(x)    (SCM_NIMP (x))
+
+
+
+SCM scm_write (SCM);
+
+
+#endif /* GYEHOEK_H */