From dc785ed8f3dca338d83472033baeaa452f6818fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Madeleine=20Sydney=20=C5=9Alaga?= Date: Thu, 14 May 2026 12:22:03 -0600 Subject: [PATCH] big --- app/Gyehoek/ANF.hs | 137 ++++++++++++++++++++++++++++++++++++------ app/Gyehoek/QBE.hs | 5 ++ app/Gyehoek/Syntax.hs | 34 ++++++++--- flake.nix | 2 + play/a.out | Bin 0 -> 18800 bytes play/t.ssa | 12 ++++ runtime/default.nix | 2 +- runtime/gyehoek.c | 10 ++- runtime/gyehoek.h | 23 +++++++ 9 files changed, 195 insertions(+), 30 deletions(-) create mode 100755 play/a.out create mode 100644 play/t.ssa create mode 100644 runtime/gyehoek.h 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 0000000000000000000000000000000000000000..5c33913afaaa77509103a39d5a505b08d43df006 GIT binary patch literal 18800 zcmb<-^>JfjWMqH=W(GS35HCRhBH{p{7(UoT84L^z4h$9yybKNuY7D9jYzzzxEMPH+ zJWM@|zQF_$htV7mE(0@Ep9F}(z`%e`2Se4tXpoygLLeGsABc?&&tQj$!e|DlKS26e zK~hjYOdLkv1u0-)V1UsuagZ?BJ_V3w1_lN+Isl}Afq?-=BkKc&O@S^%Ux6(uy#N|6 zE1)z?ABYRm*8tVm0M!Sh4L}MQ7#LtQEIdJO1mO=*_o36U_<+&q`V15y?n9@c#=*S} zvIC?t_-RQBh>dO!j1RL1M#Jn2fa=qM8jL}M3};|q(1Fq*J3!39rzI(%Z~?K2!LVo! zg4%~G9wtD;6GlU$lR-Z(vqHbPB)=$CKP$J`ysDxq*Sy@YJR`ZPJg?F;*El^pJtZqW zBRA8iNH;wvGbvfuNYBJb*VIryCo@SuCq*|WGq1Elx5C0q*UUt(IA6~Q;%ZQG=Y*zx zkbj`b6)Xv|8|oY|9~5SwGz-!L5(lXTsR8L@aA*Xn;Q)z&)Ll$Hm%ID%q#BSQHXO^q zz#xQ00%RUEDo|wIaHy9>$^yt50&u7Y#UnQJ^BEWzl#mU8vga`{FbFV6GDyG@4pf{W z-ZR8EJ|(p%H9fPqB(*5S*EuIYFEu1FDJPX7K0ZA+KQF$xB(bO@J|3bJt3r3@_}s*t zocv^l`1pdN%)FAc_~eXihWL0;3_|tiCT8X_#K$LBB*v#@<|XE2R;4oJWG1C2gJRJT z#7xNnF^xb>u%H=3d}>|_gS(HXlXJY0o{^p@oNcUUf?%64=x5~Trt0SwSEdx}7Z)Y# zr&p$C|?~7J5c{hDPX`Nl(4VRwpJIo0}Tvnq``27N?h06=dWj78xX3R3urL zq~}KW-7=z3wrkePvzfdyQjFfuSROaaF&NS=YAR4S7b zRC6qbij_!$_{A@G@B?w3dN8xD_d)|>ha z3?8iqN|^p%@Mu25aTsjvf740&3=IEOr|2^<@XI?e{8t6>GeB}LAN>FS|G#RNJ_ADr zs44aG0+_!@pMfE50!RS}gUmO4>)ClR&ZF~@NAr^p0U@r22MkYo^xDcXGBErX4c2F1 z_>!i_FW&-E&fw8&TM2SUFKZEqviwmZ>e0<=24c4!DB=A7fM31=r0_75_UN_s1WERq zI)Nz7e;%D5JPy9I_c-{2*@N+z$HjjoA|BnWtRTtO10@{)AEfciyD%`o^n={jU<;CF zDAf-2XtsT%$H2hg(fPE5$D`Z!nH~ef3(f!k|G!B2|Ns9n*1LKP42-dd`Q=gczbya% z|3B0{p&p&TnxC_Q3{dgtHC@QZz_1_Go-{o0;^M#m{|yhs8eTH|X80dwzelfWKa!fY zC~87II-l+b^<-bP{`>#mqw~1Oads|{^Nzc7@G&qjyy*M?|Nnkax9&yD|Ns9_9%f(w z`3D@I@E8Pz)+ingfzc2c4S~@R7!85Z5Eu=C(GVC7fzc2c4S~@R80jIv$iT#)Y?GOr zo0^iDSdyxsnv-J3#h`4Hk(yYbke`&5np^@EV_;yEX13OV&Ru?a|Nnms0|SG~hyVXU zJ$I82|Npyy_#glOpToewAOa0o#;PC&#tH#OX&!ct35*bN8Bo{t{r~@JAT=)RpbjpB z3IhX!2?GPeg!ljd8-T?51l;%}y!g4xIT{%3rL47#Rlw7QAagnXbuNtK4`AR-7l1Zse$1DNDMT9 z0n*0Ez=*xQKyq~;f`I|NRu07M1QAGl(AqhW5NQ1+h&~1)7#J9Mpfqg# zFfWvU0lE%O63U0IpOc32!JQ!n1_mi8AGVGT)HeeO!Q?^x9T2|&)X8CBVEFp)KWOPD z!wM)L)Q{T^9$MI|a#s`fMN? z)c*s~pmlU0S{y_$Ffe351)vne3aCS1{x|?t2U>dzVoHDr1_lN>C=FBh`#;2gj0_B5 zp?^?*2GqR&P(IW<3?HEU5UBi5C?DnzsPR;zVC%rq4KxFFN*Nd!+@LhNJRv@8eWbgy zvz3B|yI-iL0%TbynnuuiUPzpPgNGpin$Ey|ZZx$ZE=2u3Sa34Tg{n6MNn*jb7#SE? z85qHabAVEsEVH{9Brriq1)kiYS{XUmIVEBbyZi0|Qq&0|Ns$M;<666*Dj}FoW!1_LtTNu|Za_a0r8P zCNBpIm*{E+1_r)71{N;OE|3%hf3UMJ0|yHiKWL?d07yb_8c0GAB+kNR3{o!yS`N!< z!V}5B!0;M0bOK_qfUII=5C-K1Miy3(cJyFmoO1{?SW>~j$RYxg2hH(={4NR-j)8_D zBa9&ovKHi3Hr66W1_rkCj0_B*fB<=eJs+z2JOcv*6Jsc&5fftwCo>CZzyz#K3}j>j zR1qVL0XLF^6>OX*0|SFQ0|Nv5WT;A1`F^ETlEGl6H`IK4W5+efxQ;9+)11MS< zOu-Z*M>Zn^1LIx>21IhW!N|by5)@5L3=E77OrlH-4Ce5(!py*^!obaK$IZ;gz`*3m zz$8&8!N9;Q#=y*H#cj=P$?Yl3z`(-F0HRnyIh&1@!BChxVw;(R7I0GjW zEH{XM}deBJ!q%o5$4)WkI1w4%h^RNaF7%)FA+A_d*tlG40X+w|1D)S}E} z1>M}lqT~!)$gUOz-E;+AeLmblEma}-Q=9a;tbt_qWqH7ia9Np65)D+#K)bwIoFe|;F2&}ItGr2@JEhn`?H?gQFv9j3K5G)Kb4r)+- zk#2EG5hx6G)AI5`Y><}xvecrqocwYHuprnEXwFY7O3X{i&($qXO--@Q&CJa+PtPzY zGf~jhEl4a%%(X2pF3?RXO-oBH(k;%cO0_j%fP_CNCgS7Ma!VMhi%SyoQWA?mkycPz zQj2d7M?p?vB?BmC9D@~%^h`_`zPNQ#RYR{6|l0M%MB*nU4Smw|!d8CbnIyuA+- z|AS*cnIt1(3nol0h>ie@OMo_~g1B&O$_Uy|CIJsmn1l@@_Wf{fAaN!>23Y?Irrrl6 z&cKV&-VKAA&j5`tnEGU}dtf{S4QihWGD$GN+S@RhdPW8YK?Z)f=b+swhCZ`q3U7v7pQp%l3M~62eDA`UXXj3FvIO64u3sn#J->J zAIN+rE>I+(S`eIERAQ)?&k!Gjnx2^#te4M#*ytBuk{h24+Ui%# z5FekCAD^C+pOlyrpHh-vR2-jJTEUQ9H z67eaexw(}L@$pE!_{_Y_5)`Gdk}VnJywtoDkmKUx-GUr_UE^K-TtK@GT_XJ)eLbBS z;^W=@LgQUMpt2q=K@9QkKK@RQKJor;Zo#f0@ga^*KCbbY+YKFHTL+CzAe$Ev-bdZ% zn3|GUlE{Fxi!m)TFB7S~5g!jy0NKchu`4n@r8qx6BQY-pv}4lKKOR(!=f#66V#xl* z`1qvaVyIql#f7{_65&KW6NdQs5MO7Q_dP>=SMG!gz#sW7#3K;a#^GfwH5{ok!^inGGiYs#=bV(6JrYyCnI5R&Fg%e-IpjVWd zlL*oPWfkO z5(d4L)TGk%_{5^by!6y!7&kL7Eg!~COiC(BEraoLGV@Yl>|#&=K=gxzW!R8vB5Z0pQ-Z4>KR67RCnA>fnYqsLlfM7#LvVN-)|2A`CuL z0K^0j1c2)r5RZXDnSp`f+yDRhF#BQSP%s*_J^`c>R(`_tgTz1>w5=Z0`GDz%jZ?ws z8z4ncH-g*_(+}!Zf}}wG8PIS9Oh0Vg3r54nxj4%LQ!DvuN zAEXxMewaEK4Qd~N#-w0;*tisohE+qLaXFCPF!zJZ1YuCG9Aq|3KWv-~M#IL*Kx#nh zVftbIPlm>Y6G)N)G42K%e}j$Ff%JpM=Fs)$g6n$*@VOCSBVg?!C=E(qU~wn`G6%{8 zQ=pwEAb&xJ+ZYs}`d~E7ez0QbUSbd%s*C|N^n$EE04f2aVeSR#0bv*)MuRrkBkPCN zzc4xvBni?8#Zcp+JO+j)H2=fe888|)ehbrp?*9&`epvj$4`zV2&p;hom|hT#t{=29 z2joPUepq`9PJ=WdVRZeV{rSlHBcS%e=ov_QK}=Y5K@w05(+8s;GCVJ^b}KaF!0bWS595D;`VnS7teq(U)eo}= zrXG}5U~CZm6>2|JIYRxw;X!D2dMoG;=?eyT6G-uTY)-+ptOai0gcOG4Al>H zF3cJRPf*1Kn$N-EewaCSIP@o*LyY2qDTHvr{bLXlChP~*4-!Mh`Ou0x9$64eT*cwg ze-5f2RA(R?0kan-2I8Z65iIors(%7BVS=UuKxqk<9%1ztCsN)AYlIRNHV_62n&BY( ZATkgVH0l7g0wMq +#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 */