diff --git a/app/Gyehoek/ANF.hs b/app/Gyehoek/ANF.hs index e83a159..747d3cf 100644 --- 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) diff --git a/app/Gyehoek/QBE.hs b/app/Gyehoek/QBE.hs index 5a50b2b..26aacc5 100644 --- 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 diff --git a/app/Gyehoek/Syntax.hs b/app/Gyehoek/Syntax.hs index 5e012cd..bb1b358 100644 --- 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 diff --git a/flake.nix b/flake.nix index 136e5d2..6afd30b 100644 --- a/flake.nix +++ b/flake.nix @@ -44,6 +44,8 @@ qbe haskellPackages.cabal-fmt schemat + bdwgc + pkg-config ]; }; }; diff --git a/play/a.out b/play/a.out new file mode 100755 index 0000000..5c33913 Binary files /dev/null and b/play/a.out differ diff --git a/play/t.ssa b/play/t.ssa new file mode 100644 index 0000000..5c0952c --- /dev/null +++ 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 +} \ No newline at end of file diff --git a/runtime/default.nix b/runtime/default.nix index 0e6017f..c80a21d 100644 --- a/runtime/default.nix +++ b/runtime/default.nix @@ -1,6 +1,6 @@ { stdenv , callPackage -, bdwgc ? callPackage ./bdwgc.nix {} +, bdwgc ? callPackage ../bdwgc.nix {} }: stdenv.mkDerivation { diff --git a/runtime/gyehoek.c b/runtime/gyehoek.c index 235f583..8ba51fd 100644 --- a/runtime/gyehoek.c +++ b/runtime/gyehoek.c @@ -1,5 +1,11 @@ #include +#include "gyehoek.h" -int blah () { - puts ("aaa"); +SCM scm_write (SCM x) { + if (SCM_IMP (x)) { + printf ("#\n", SCM_UNPACK (x)); + } else { + printf ("#\n", SCM_UNPACK(x)); + } + return SCM_PACK(NULL); } diff --git a/runtime/gyehoek.h b/runtime/gyehoek.h new file mode 100644 index 0000000..3b220c5 --- /dev/null +++ b/runtime/gyehoek.h @@ -0,0 +1,23 @@ +#ifndef GYEHOEK_H +#define GYEHOEK_H + +#include + + + +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 */