big

2026-05-14 12:22:03 -06:00
parent ff6bddffb3
commit dc785ed8f3
9 changed files with 195 additions and 30 deletions
--- a/app/Gyehoek/ANF.hs
+++ b/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
-  primfns = [ mkArith "plus" QBE.Add
-            , mkArith "star" QBE.Mul
-            , mkArith "_" QBE.Sub
-            , mkArith "slash" (QBE.Div QBE.Signed)
+prims = QBE.Program primtys mempty primfns where
+  primtys =
+    [ QBE.TypeDef "scm" Nothing
+      [ (QBE.SubExtTy (QBE.BaseTy QBE.Long), Just 2) ]
+    ]
+  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 =
-  k . QBE.ValConst . QBE.CInt . fromIntegral $ n
+lowerVal (ValLit (LitInt n)) k = k . lowerInt $ 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 -> _
-lowerCons = _
+sizeofScm = 16
+
+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)) ->
-      Emit [ QBE.BinaryOp r bop a b ] <$> lower' e k
-    PrimCons x y -> _
+    (preview binaryPrim -> Just (bop,a,b)) -> do
+      r1 <- gensym
+      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)
--- a/app/Gyehoek/QBE.hs
+++ b/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

--- a/app/Gyehoek/Syntax.hs
+++ b/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 "prim:-")
-    $ With (. binop "prim:*")
-    $ With (. binop "prim:/")
-    $ With (. binop "prim:cons")
+    $ With (. binop "+")
+    $ With (. binop "-")
+    $ With (. binop "*")
+    $ With (. binop "/")
+    $ 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
--- a/flake.nix
+++ b/flake.nix
@@ -44,6 +44,8 @@
                qbe
                haskellPackages.cabal-fmt
                schemat
+                bdwgc
+                pkg-config
              ];
            };
          };
--- a/play/a.out
+++ b/play/a.out
--- a/play/t.ssa
+++ b/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
+}
--- a/runtime/default.nix
+++ b/runtime/default.nix
@@ -1,6 +1,6 @@
 { stdenv
 , callPackage
-, bdwgc ? callPackage ./bdwgc.nix {}
+, bdwgc ? callPackage ../bdwgc.nix {}
 }:

 stdenv.mkDerivation {
--- a/runtime/gyehoek.c
+++ b/runtime/gyehoek.c
@@ -1,5 +1,11 @@
 #include <stdio.h>
+#include "gyehoek.h"

-int blah () {
-  puts ("aaa");
+SCM scm_write (SCM x) {
+  if (SCM_IMP (x)) {
+    printf ("#<immediate %ld>\n", SCM_UNPACK (x));
+  } else {
+    printf ("#<heap object %ld>\n", SCM_UNPACK(x));
+  }
+  return SCM_PACK(NULL);
 }
--- a/runtime/gyehoek.h
+++ b/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 */