msyds/gyehoek-hs
1
0
Fork 0
Code Issues Pull Requests 1 Actions Packages Projects Releases Wiki Activity

cps

Browse Source
This commit is contained in:
msyds
2026-06-30 11:52:46 -06:00
parent 37b97f9eb3
commit ee84bdb1f5
42 changed files with 30 additions and 1526 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Gyehoek/ANF/Syntax.hs
-574
View File
@@ -1,574 +0,0 @@
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-unused-matches -Wno-missing-signatures #-}
{- HLINT ignore "Avoid lambda using `infix`" -}
module Gyehoek.ANF.Syntax
( Exp(..)
, toANF
, lower
, wrapFunction
, lowerProgram
)
where
import Data.Text (Text)
import Effectful
import Gyehoek.QBE qualified as QBE
import Data.List (List)
import Data.Text.IO qualified as TIO
import Control.Lens
import Data.Generics.Labels
import Data.Vector.Strict (Vector)
import Data.Function (fix)
import Effectful.Writer.Static.Local
import Gyehoek.Scheme.Syntax qualified as Lam
import Gyehoek.Scheme.Syntax (Name, Prim(..), Lit(..))
import Gyehoek.GenSym
import Control.Monad.Cont
import Data.Foldable
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.List.NonEmpty qualified as NE
import Gyehoek.QBE (FuncDef(FuncDef))
import Data.Foldable1
import qualified Data.Text as T
import Data.String (fromString)
import Language.SexpGrammar as Sexp hiding (List, iso, encode, decode, traversed)
import Language.SexpGrammar.Generic
import GHC.Generics (Generic)
import Gyehoek.Sexp
import Control.Category
import Prelude hiding ((.), id)
import Data.InvertibleGrammar.Base qualified as IG
import Data.InvertibleGrammar.Base ((:-)((:-)))
import qualified Gyehoek.Sexp
import Control.Lens.Unsound
import qualified Data.Bits
import qualified GHC.IO.Encoding as T
import qualified Data.Text.Encoding as T
import Data.HashMap.Strict (HashMap)
import Effectful.State.Static.Local
import qualified Data.HashMap.Strict as HM
data Val
= ValLit Lit
| ValVar Name
deriving (Show, Generic)
data Exp
= ExpLetApply Name Val (List Val) Exp
| ExpLetPrim Name (Prim Val) Exp
| ExpBegin (List Exp)
| ExpVal Val
deriving (Show, Generic)
expandBindings
-- | Match constructor. (an affine fold would be preferable to a
-- prism here)
:: Prism' e (lhs, rhs, e)
-> e
-> (List (lhs, rhs), e)
expandBindings p = go [] where
go acc e =
case e ^? p of
Just (l,r,e') -> go ((l,r):acc) e'
Nothing -> (acc, e)
collapseBindings
:: Foldable f => AReview e (lhs, rhs, e) -> f (lhs, rhs)
-> e -> e
collapseBindings p bs e = foldr (\(l,r) e' -> p # (l,r,e')) e bs
-- | Technically unlawful.
bindingTelescope
:: Prism' e (lhs, rhs, e)
-> Iso' e (List (lhs, rhs), e)
bindingTelescope p = iso
(expandBindings p)
(uncurry $ collapseBindings p)
foldLet
:: Prism' Exp (lhs, rhs, Exp)
-> Grammar
Position
(Exp :- NonEmpty (lhs, rhs) :- t)
(Exp :- rhs :- lhs :- t)
foldLet p =
IG.Iso
(\(e :- ((l1,r1):|bs) :- t) ->
collapseBindings p bs e :- r1 :- l1 :- t)
(\(e :- r :- l :- t) ->
let (bs,e') = expandBindings p e
in e' :- ((l,r) :| bs) :- t)
instance SexpIso Val where
sexpIso = match
$ With (. sexpIso)
$ With (. symbol)
$ End
nonEmptyIso :: Iso (NonEmpty a) (NonEmpty b) (a, List a) (b, List b)
nonEmptyIso = iso (\(x:|xs) -> (x,xs)) (uncurry (:|))
-- nonEmptyGrammar :: Grammar p (NonEmpty x :- t) (List x :- x :- t)
-- nonEmptyGrammar = IG.Iso
-- (\((x:|xs) :- t) -> xs :- x :- t)
-- (\(xs :- x :- t) -> (x:|xs) :- t)
instance SexpIso Exp where
sexpIso = match
$ With (. letapp)
$ With (. letprim)
$ With (\bgn -> bgn . list (el (sym "begin") >>> rest sexpIso))
$ With (. sexpIso)
$ End
where
letprim
:: Grammar Position (Sexp :- t) (Exp :- (Prim Val :- (Text :- t)))
letprim =
Gyehoek.Sexp.let_ symbol (sexpIso @(Prim Val)) (sexpIso @Exp)
>>> foldLet #ExpLetPrim
letapp :: Grammar
Position (Sexp :- t) (Exp :- List Val :- Val :- Text :- t)
letapp =
Gyehoek.Sexp.let_ symbol (sexpIso @(NonEmpty Val)) (sexpIso @Exp)
>>> foldLet (#ExpLetApply
. iso (\(rhs,f,xs,e) -> (rhs, f:|xs, e))
(\(rhs,f:|xs,e) -> (rhs,f,xs,e)))
>>> onTail nonEmptyGrammar
-- 뻘짓이어라
telescope :: Traversable t => t ((a -> r) -> r) -> (t a -> r) -> r
telescope = runCont . traverse cont
toANF'
:: forall es. GenSym :> es
=> Lam.Exp
-> (Val -> Eff es Exp)
-> Eff es Exp
toANF' (Lam.ExpLit v) k = k . ValLit $ v
toANF' (Lam.ExpPrim p) k =
telescope (toANF' <$> p) \p' -> do
r <- gensym
ExpLetPrim r p' <$> k (ValVar r)
toANF' (Lam.ExpApply f xs) k =
telescope (toANF' <$> (f:|xs)) \(f':|xs') -> do
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' (Lam.ExpLet xs e) k = _
toANF' e k = _
toANF e = toANF' e (pure . ExpVal)
expr =
Lam.ExpPrim
(PrimAdd
(Lam.ExpPrim
(PrimMul
(Lam.ExpLit (LitInt 2))
(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.ExpPrim
(PrimMul
(Lam.ExpLit (LitInt 5))
(Lam.ExpLit (LitInt 4)))))
]
instance Semigroup QBE.Program where
QBE.Program ts ds fs <> QBE.Program ts' ds' fs' =
QBE.Program (ts <> ts') (ds <> ds') (fs <> fs')
instance Monoid QBE.Program where
mempty :: QBE.Program
mempty = QBE.Program mempty mempty mempty
funcdef
:: QBE.Ident QBE.Global
-> List QBE.Param -> NonEmpty QBE.Block -> FuncDef
funcdef name ps =
QBE.FuncDef
mempty
(Just (QBE.AbiBaseTy QBE.Long))
name Nothing ps QBE.NoVariadic
prims :: QBE.Program
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
[ QBE.Param (QBE.AbiBaseTy QBE.Long) "x"
, QBE.Param (QBE.AbiBaseTy QBE.Long) "y"
]
[ QBE.Block "start" []
[ QBE.BinaryOp ("r" QBE.:= QBE.Long) bop
(QBE.ValTemporary "x") (QBE.ValTemporary "y")
]
(QBE.Ret (Just (QBE.ValTemporary "r")))
]
data BlockBuilder
= Emit (Vector QBE.Inst) !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)
evalBlockBuilder :: BlockBuilder -> (Vector QBE.Inst, QBE.Jump)
evalBlockBuilder (Emit is bb) = evalBlockBuilder bb & _1 <>:~ is
evalBlockBuilder (Exit j) = ([],j)
buildBlock :: QBE.Ident QBE.Label -> BlockBuilder -> QBE.Block
buildBlock n bb = QBE.Block n [] (is ^.. each) j
where (is,j) = evalBlockBuilder bb
lowerName :: Name -> QBE.Ident t
lowerName = fromString . T.unpack
lowerInt' = QBE.ValConst . QBE.CInt . fromIntegral
lowerInt = QBE.ValConst . QBE.CInt
. (Data.Bits..|. 2)
. (Data.Bits..<<. 2)
. fromIntegral
lowerString
:: forall es. (GenSym :> es, State StringLiterals :> es)
=> Text -> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
lowerString s k = do
let len = lengthOf each $ T.encodeUtf8 s
rawString <- getRawString
r <- gensym
Emit (alloc r rawString len) <$> k (QBE.ValTemporary r)
where
-- getRawString
-- :: forall es. (GenSym :> es, State StringLiterals :> es)
-- => Eff es _
getRawString = do
x <- get
case x ^. at s of
Just s' -> pure s'
Nothing -> do r <- gensym
state \lits -> (r, HM.insert s r lits)
alloc r rs len =
[ QBE.Call
(Just (r, QBE.AbiBaseTy QBE.Long))
(QBE.ValGlobal "scm_from_utf8_string")
Nothing
[ QBE.Arg (QBE.AbiBaseTy QBE.Long) (QBE.ValGlobal rs)
-- N.b. The C function declares this argument as size_t, which
-- /is/ long on my system.
, QBE.Arg (QBE.AbiBaseTy QBE.Long) (lowerInt' len)
]
[]
]
type StringLiterals = HashMap Text (QBE.Ident QBE.Global)
lowerVal
:: forall es. (GenSym :> es, State StringLiterals :> es)
=> Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
lowerVal (ValLit (LitInt n)) k = k . lowerInt $ n
lowerVal (ValLit (LitQuote (Lam.SexpSymbol s))) k =
lowerString s \s' -> do
r <- gensym
Emit (intern r s') <$> k (QBE.ValTemporary r)
where
intern r s' =
[ QBE.Call
(Just (r, QBE.AbiBaseTy QBE.Long))
(QBE.ValGlobal "scm_string_to_symbol")
Nothing
[ QBE.Arg (QBE.AbiBaseTy QBE.Long) s'
]
[]
]
lowerVal (ValLit (LitString s)) k = lowerString s k
lowerVal (ValLit _) k = error "todo"
lowerVal (ValVar x) k = k . QBE.ValTemporary . lowerName $ x
binaryPrim :: Prism' (Prim a) (QBE.BinaryOp, a, a)
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)
_ -> _
sizeofScm :: Integral a => a
sizeofScm = 8
lowerCons
:: (GenSym :> es, State StringLiterals :> 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 * 2))) ]
[]
]
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.Ident 'QBE.Temporary
-> QBE.BinaryOp
-> QBE.Val -> QBE.Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
smallIntHelper' r bop v1 v2 k = do
Emit [ QBE.BinaryOp (r QBE.:= QBE.Long)
bop v1 v2 ]
<$> k (QBE.ValTemporary r)
smallIntHelper
:: GenSym :> es
=> QBE.BinaryOp
-> QBE.Val -> QBE.Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
smallIntHelper bop a b k = do
r <- gensym
smallIntHelper' r bop a b k
makeSmallInt'
:: forall es. (GenSym :> es)
=> QBE.Ident 'QBE.Temporary
-> QBE.Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
makeSmallInt' r n k =
smallIntHelper QBE.Shl n (lowerInt' 2) \n' ->
smallIntHelper' r QBE.Add n' (lowerInt' 2) k
makeSmallInt
:: forall es. (GenSym :> es)
=> QBE.Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
makeSmallInt n k = do
r <- gensym
makeSmallInt' r n k
getSmallInt
:: forall es. (GenSym :> es)
=> QBE.Val
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
getSmallInt n = smallIntHelper QBE.Shr n (lowerInt' 2)
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))
smallIntMask :: Integer
smallIntMask = 2 ^ (sizeofScm * 8) - 2
lowerCar
:: (GenSym :> es, State StringLiterals :> es)
=> Name -> QBE.Val -> _
-> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
lowerCar r x e k = do
Emit [ QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long x
]
<$> lower' e k
lowerCdr
:: (GenSym :> es, State StringLiterals :> es)
=> Name -> QBE.Val -> Exp
-> (QBE.Val -> Eff es BlockBuilder) -> Eff es BlockBuilder
lowerCdr r x e k = do
x1 <- gensym
Emit [ QBE.BinaryOp (x1 QBE.:= QBE.Long)
QBE.Add x (lowerInt' sizeofScm)
, QBE.Load (lowerName r QBE.:= QBE.Long) QBE.Long
(QBE.ValTemporary x1)
]
<$> lower' e k
lowerNewline r k =
Emit [ QBE.Call (Just (lowerName r, QBE.AbiBaseTy QBE.Long))
(QBE.ValGlobal "scm_newline") Nothing
[]
[]
]
<$> k (QBE.ValTemporary (lowerName r))
lowerPrim
:: forall es. (GenSym :> es, State StringLiterals :> 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)) ->
getSmallInt a \a' ->
getSmallInt b \b' ->
smallIntHelper bop a' b' \c ->
makeSmallInt' (lowerName r) c \_ ->
lower' e k
PrimCons x y -> lowerCons r x y e k
PrimCar x -> lowerCar r x e k
PrimCdr x -> lowerCdr r x e k
PrimWrite x -> lowerWrite r x e k
PrimNewline -> lowerNewline r k
lower'
:: forall es. (GenSym :> es, State StringLiterals :> es)
=> Exp
-> (QBE.Val -> Eff es BlockBuilder)
-> Eff es BlockBuilder
lower' (ExpVal v) k = lowerVal v k
lower' (ExpLetPrim r p e) k = lowerPrim r p e k
lower' (ExpLetApply r f xs e) k =
telescope (lowerVal @es <$> (f:|xs)) \(f':|xs') ->
Emit [ QBE.Call
(Just (lowerName r, QBE.AbiBaseTy QBE.Long))
f'
Nothing
(QBE.Arg (QBE.AbiBaseTy QBE.Long) <$> xs')
[]
]
<$> 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, State StringLiterals :> es)
=> QBE.Ident QBE.Label
-> Exp
-> Eff es QBE.Block
lower n e = buildBlock n <$> lower' e (pure . Exit . QBE.Ret . Just)
lowerStringLiterals =
ifoldMapOf itraversed \s v ->
[ QBE.DataDef [] v Nothing
[QBE.FieldExtTy QBE.Byte [QBE.String (T.encodeUtf8 s)]]]
lowerProgram
:: (GenSym :> es, Traversable t)
=> t Exp -> Eff es QBE.Program
lowerProgram anfs =
case toList anfs of
-- hack for dev convenience: if there's only one expression, let
-- it be the entry point.
[e] -> do
(b,stringLits) <- runState mempty . lower "start" $ e
let f = wrapFunction @NonEmpty "main" [b]
dataDefs = lowerStringLiterals stringLits
pure $ QBE.Program [] dataDefs [f]
_ -> do
let low e = do
bl <- gensym' "b"
fl <- gensym' "f"
b <- lower bl e
pure $ wrapFunction @NonEmpty fl [b]
(fs,stringLits) <- runState mempty $ traverse low anfs
pure $ QBE.Program [] (lowerStringLiterals stringLits) (fs ^.. traversed)
wrapFunction
:: Foldable1 t
=> QBE.Ident 'QBE.Global -> t QBE.Block -> QBE.FuncDef
wrapFunction l bs =
QBE.FuncDef [QBE.Export]
(Just (QBE.AbiBaseTy QBE.Word))
l Nothing [] QBE.NoVariadic (toNonEmpty bs)
wrapProgram :: Foldable1 t => t QBE.Block -> QBE.Program
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/CPS/Convert.hs
+1
View File
@@ -0,0 +1 @@
module Gyehoek.CPS.Convert where
app/Gyehoek/CPS/Syntax.hs
+1
View File
@@ -0,0 +1 @@
module Gyehoek.CPS.Syntax where
app/Gyehoek/QBE/Parse.hs
-194
View File
@@ -1,194 +0,0 @@
{-# LANGUAGE RequiredTypeArguments #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE PartialTypeSignatures #-}
module Gyehoek.QBE.Parse where
import Language.QBE as QBE
import Effectful.State.Dynamic
import Effectful.Dispatch.Dynamic
import Effectful
import Numeric.Natural
import Data.String (IsString(fromString))
import Prettyprinter (Pretty(pretty), layoutPretty, defaultLayoutOptions)
import Data.Text (Text)
import Data.Data
import Prettyprinter.Render.Text (renderStrict)
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
import Data.Void (Void)
import Data.Char (isAlpha, isAlphaNum)
import Control.Lens.Wrapped
import Data.Functor.Contravariant (Predicate(Predicate))
import qualified Data.Text as T
import Data.Functor
import Data.List (List)
import Data.Foldable (fold)
import Data.Maybe (isJust, fromMaybe)
import Control.Monad.Fix (MonadFix(mfix))
import Data.List.NonEmpty (fromList)
import Language.Haskell.TH qualified as TH
import Language.Haskell.TH.Quote
import Data.Proxy
import Data.Kind (Type)
type P = Parsec Void Text
sc :: P ()
sc = L.space hspace1 (L.skipLineComment "#") empty
lexeme :: P a -> P a
lexeme = L.lexeme sc
symbol :: Text -> P Text
symbol = L.symbol sc
infixr 8 .:
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(.:) f g x y = f (g x y)
rawIdent :: P QBE.RawIdent
rawIdent = (fromString .: (:) <$> lead <*> trail) <?> "ident"
where
lead = satisfy \x -> isAlpha x || (x=='.') || (x=='_')
trail = fmap T.unpack . takeWhileP Nothing $ \x ->
isAlphaNum x || (x=='.') || (x=='_')
class ParseIdent (s :: Sigil) where
ident :: P (QBE.Ident s)
rawIdentWithSigil :: Char -> P (Ident t)
rawIdentWithSigil c = Ident <$> lexeme (char c *> rawIdent)
instance ParseIdent AggregateTy where ident = rawIdentWithSigil ':'
instance ParseIdent Global where ident = rawIdentWithSigil '$'
instance ParseIdent Temporary where ident = rawIdentWithSigil '%'
instance ParseIdent QBE.Label where ident = rawIdentWithSigil '@'
const :: P QBE.Const
const = cint <|> csingle <|> cdouble <|> cglobal <?> "const"
where
cint = CInt <$> lexeme (L.signed empty L.decimal) <?> "integer"
csingle = empty <?> "single-precision float"
cdouble = empty <?> "double-precision float"
cglobal = CGlobal <$> ident <?> "global symbol"
val :: P QBE.Val
val = vconst <|> vtemp <?> "val"
where
vconst = ValConst <$> Gyehoek.QBE.Parse.const
vtemp = ValTemporary <$> ident <?> "temporary symbol"
assignment :: P QBE.Assignment
assignment =
Assignment <$> ident <*> (char '=' *> basety)
basety :: P QBE.BaseTy
basety = lexeme $ char 'w' $> Word
<|> char 'l' $> Long
<|> char 's' $> Single
<|> char 'd' $> Double
abity :: P AbiTy
abity = AbiBaseTy <$> basety
<|> AbiAggregateTy <$> ident
binaryOp :: P QBE.BinaryOp
binaryOp = lexeme $ "add" $> Add
<|> "sub" $> Sub
<|> "mul" $> Mul
<|> "div" $> Div Signed
comma :: P a -> P a
comma p = symbol "," *> p
inst :: P QBE.Inst
inst = try binaryOpInst <|> negInst <?> "inst"
where
binaryOpInst =
BinaryOp
<$> assignment
<*> binaryOp
<*> val <*> comma val
negInst = Neg <$> assignment <*> (symbol "neg" *> val)
jump :: P QBE.Jump
jump = jmp <|> jnz <|> ret <|> hlt <?> "jump"
where
jmp = symbol "jmp" *> (Jmp <$> ident)
jnz = symbol "jnz" *> (Jnz <$> val <*> ident <*> comma ident)
ret = symbol "ret" *> (Ret <$> optional val)
hlt = empty
nl :: P ()
nl = void (some (newline *> sc)) <?> "newline"
phi :: P QBE.Phi
phi = empty
block :: P QBE.Block
block = Block
<$> (ident <* nl)
<*> sepBy phi nl
<*> sepBy inst nl
<*> jump
sepByTry :: MonadParsec e s m => m a -> m sep -> m (List a)
sepByTry p sep = do
x <- p
xs <- many (try $ sep *> p)
pure (x:xs)
paramList :: P (Maybe (Ident Temporary), List Param, Variadic)
paramList = label "parameter list" $ between (symbol "(") (symbol ")") do
e <- optional env
ps <- optional . try $ do
commaIf (isJust e)
sepByTry reg (symbol ",")
v <- optional do
commaIf (isJust e || isJust ps)
variadic
pure (e, fromMaybe [] ps, fromMaybe NoVariadic v)
where
commaIf True = void $ symbol ","
commaIf False = pure ()
env = symbol "env" *> ident @Temporary <?> "environment parameter"
reg = Param <$> abity <*> ident <?> "regular parameter"
variadic = symbol "..." $> Variadic <?> "variadic parameter"
funcdef :: P QBE.FuncDef
funcdef = do
linkages <- many linkage
symbol "function"
returnTy <- optional abity
name <- ident @Global
(env,params,variadic) <- paramList
code <- fmap fromList . between (symbol "{" *> nl) (symbol "}") $
sepEndBy1 block nl
pure $ FuncDef linkages returnTy name env params variadic code
linkage :: P Linkage
linkage = symbol "export" $> Export
-- stripped :: P a -> P a
-- stripped p = optional nl *>
class Data a => Parser a where
parser :: P a
instance Parser FuncDef where parser = funcdef
class ParseSeparator a where
parseSeparator :: Proxy a -> P ()
instance (Parser a, ParseSeparator a) => Parser (List a) where
parser = sepBy parser (parseSeparator @a Proxy)
instance ParseSeparator FuncDef where parseSeparator _ = nl
instance ParseSeparator Block where parseSeparator _ = nl
example/ascii-string-literal
BIN
View File
Binary file not shown.
example/ascii-string-literal.anf
-4
View File
@@ -1,4 +0,0 @@
;;; -*- mode:scheme -*-
(let ((x0 (prim:write "wawa"))) x0)
example/ascii-string-literal.s
-23
View File
@@ -1,23 +0,0 @@
.data
.balign 8
.1:
.ascii "wawa"
/* end data */
.text
.globl main
main:
pushq %rbp
movq %rsp, %rbp
movl $4, %esi
leaq .1(%rip), %rdi
callq scm_from_utf8_string
movq %rax, %rdi
callq scm_write
leave
ret
.type main, @function
.size main, .-main
/* end function main */
.section .note.GNU-stack,"",@progbits
example/ascii-string-literal.scm
-1
View File
@@ -1 +0,0 @@
(prim:write "wawa")
example/ascii-string-literal.ssa
-10
View File
@@ -1,10 +0,0 @@
data $.1 =
{b "wawa"}
export
function w $main () {
@start
%.2 =l call $scm_from_utf8_string (l $.1, l 4)
%x0 =l call $scm_write (l %.2)
ret %x0
}
example/cons
BIN
View File
Binary file not shown.
example/cons.anf
-4
View File
@@ -1,4 +0,0 @@
;;; -*- mode:scheme -*-
(let ((x0 (prim:cons 4 5)) (x1 (prim:write x0))) x1)
example/cons.s
-18
View File
@@ -1,18 +0,0 @@
.text
.globl main
main:
pushq %rbp
movq %rsp, %rbp
movl $16, %edi
callq GC_malloc
movq %rax, %rdi
movq $18, (%rdi)
movq $22, 8(%rdi)
callq scm_write
leave
ret
.type main, @function
.size main, .-main
/* end function main */
.section .note.GNU-stack,"",@progbits
example/cons.scm
-1
View File
@@ -1 +0,0 @@
(prim:write (prim:cons 4 5))
example/cons.ssa
-10
View File
@@ -1,10 +0,0 @@
export
function w $main () {
@start
%x0 =l call $GC_malloc (l 16)
%.2 =l add %x0, 8
storel 18, %x0
storel 22, %.2
%x1 =l call $scm_write (l %x0)
ret %x1
}
example/pseudo/closure.scm
-15
View File
@@ -1,15 +0,0 @@
(define (adder x)
(lambda (y)
(+ x y)))
((adder 3) 4)
(define (adder x)
(list (lambda (self y)
(+ (nth self 1) y))
x))
(let ((closure (adder 3)))
((nth closure 0) closure 4))
example/pseudo/t.s
-70
View File
@@ -1,70 +0,0 @@
.text
zerop:
pushq %rbp
movq %rsp, %rbp
cmpl $0, %edi
jnz .Lbb2
movl $1, %eax
jmp .Lbb3
.Lbb2:
movl $0, %eax
.Lbb3:
leave
ret
.type zerop, @function
.size zerop, .-zerop
/* end function zerop */
.text
factorial:
pushq %rbp
movq %rsp, %rbp
subq $8, %rsp
pushq %rbx
movq %rdi, %rbx
callq zerop
movq %rbx, %rdi
cmpl $0, %eax
jnz .Lbb6
movq %rdi, %rbx
subq $1, %rdi
callq factorial
movq %rbx, %rdi
imulq %rdi, %rax
jmp .Lbb7
.Lbb6:
movl $1, %eax
.Lbb7:
popq %rbx
leave
ret
.type factorial, @function
.size factorial, .-factorial
/* end function factorial */
.data
.balign 8
fstr:
.ascii "fac 3 = %d\n"
.byte 0
/* end data */
.text
.globl main
main:
pushq %rbp
movq %rsp, %rbp
movl $3, %edi
callq factorial
movq %rax, %rsi
leaq fstr(%rip), %rdi
movl $0, %eax
callq printf
movl $0, %eax
leave
ret
.type main, @function
.size main, .-main
/* end function main */
.section .note.GNU-stack,"",@progbits
example/pseudo/t.scm
-16
View File
@@ -1,16 +0,0 @@
(define (factorial n)
(if (zero? n)
1
(* n (factorial (- n 1)))))
;;; ANF
(define (factorial n)
(let ((r₁ (zero? n)))
(if r₁
1
(let ((r₂ (- n 1))
(r₃ (factorial r₂))
(r₄ (* n r₃)))
r₄))))
example/pseudo/t.ssa
-30
View File
@@ -1,30 +0,0 @@
function l $zerop (l %n) {
@start
jnz %n, @b1, @b2
@b1
ret 0
@b2
ret 1
}
function l $factorial (l %n) {
@start
%r1 =l call $zerop (l %n)
jnz %r1, @b1, @b2
@b1
ret 1
@b2
%r2 =l sub %n, 1
%r3 =l call $factorial (l %r2)
%r4 =l mul %n, %r3
ret %r4
}
data $fstr = { b "fac 3 = %d\n", b 0 }
export function w $main () {
@start
%r =l call $factorial (l 3)
call $printf (l $fstr, ..., l %r)
ret 0
}
example/string-literal
BIN
View File
Binary file not shown.
example/string-literal.anf
-4
View File
@@ -1,4 +0,0 @@
;;; -*- mode:scheme -*-
(let ((x0 (prim:write "안녕하세요"))) x0)
example/string-literal.s
-23
View File
@@ -1,23 +0,0 @@
.data
.balign 8
.1:
.ascii "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"
/* end data */
.text
.globl main
main:
pushq %rbp
movq %rsp, %rbp
movl $15, %esi
leaq .1(%rip), %rdi
callq scm_from_utf8_string
movq %rax, %rdi
callq scm_write
leave
ret
.type main, @function
.size main, .-main
/* end function main */
.section .note.GNU-stack,"",@progbits
example/string-literal.scm
-1
View File
@@ -1 +0,0 @@
(prim:write "안녕하세요")
example/string-literal.ssa
-10
View File
@@ -1,10 +0,0 @@
data $.1 =
{b "\354\225\210\353\205\225\355\225\230\354\204\270\354\232\224"}
export
function w $main () {
@start
%.2 =l call $scm_from_utf8_string (l $.1, l 15)
%x0 =l call $scm_write (l %.2)
ret %x0
}
flake.nix
+9 -16
View File
@@ -18,19 +18,13 @@
overlays = [
haskellNix.overlay
(final: prev: {
inherit (sydpkgs.packages.${final.stdenv.hostPlatform.system})
bdwgc;
})
(final: prev: {
gyehoek = final.haskell-nix.project' {
src = ./.;
compiler-nix-name = "ghc912";
shell = {
withHoogle = true;
inputsFrom = [
self.packages.${final.stdenv.hostPlatform.system}.runtime
];
inputsFrom = [];
tools = {
cabal = {};
haskell-language-server = {};
@@ -39,13 +33,13 @@
gcc
qbe
haskellPackages.cabal-fmt
bdwgc
pkg-config
guile
clang-tools # clangd
gdb
gdbgui
rust-analyzer
self.packages.${final.stdenv.hostPlatform.system}.shake
final.wabt
final.nodejs
final.wasmtime
final.wasm-tools
final.wac-cli
final.guile
];
};
};
@@ -76,8 +70,7 @@
packages = each-system ({ pkgs, system, ... }:
hf.packages.${system} // {
default = hf.packages.${system}."gyehoek:exe:gyehoek";
runtime = pkgs.callPackage ./runtime {};
inherit (pkgs) bdwgc;
shake = pkgs.callPackage ./shake-wrapper.nix {};
});
devShells = each-system
gyehoek.cabal
+5 -7
View File
@@ -20,8 +20,7 @@ common ghcstuffs-dev
common ghcstuffs
ghc-options:
-Wall -fdefer-type-errors -fno-show-valid-hole-fits
-fdefer-out-of-scope-variables -fplugin=Effectful.Plugin
-threaded
-fdefer-out-of-scope-variables -fplugin=Effectful.Plugin -threaded
default-extensions:
BlockArguments
@@ -36,17 +35,18 @@ executable gyehoek
-- cabal-fmt: expand app -Main
other-modules:
Gyehoek.ANF.Syntax
Gyehoek.CPS.Convert
Gyehoek.CPS.Syntax
Gyehoek.GenSym
Gyehoek.Options
Gyehoek.QBE
Gyehoek.QBE.Parse
Gyehoek.Scheme.Syntax
Gyehoek.Sexp
build-depends:
, base ^>=4.21.2.0
, containers
, cradle
, effectful
, effectful-core
, effectful-plugin
@@ -59,15 +59,13 @@ executable gyehoek
, optparse-applicative
, prettyprinter
, process
, qbe
, recursion-schemes
, sexp-grammar
, template-haskell
, text
, text-short
, unordered-containers
, vector
, text-short
, cradle
hs-source-dirs: app
default-language: GHC2024
play/.gitignore
-4
View File
@@ -1,4 +0,0 @@
*.anf
*.s
*.ssa
*.out
play/car.scm
-1
View File
@@ -1 +0,0 @@
(prim:write (prim:car (prim:cons 123 456)))
play/cdr.scm
-1
View File
@@ -1 +0,0 @@
(prim:write (prim:cdr (prim:cons 123 456)))
play/string.scm
-1
View File
@@ -1 +0,0 @@
(prim:write "abc")
play/symbol.scm
-3
View File
@@ -1,3 +0,0 @@
(begin (prim:write 'abc)
(prim:newline)
(prim:write 'abc))
play/write-cons.scm
-1
View File
@@ -1 +0,0 @@
(prim:write (prim:cons 4 2))
runtime/.gitignore
-1
View File
@@ -1 +0,0 @@
target
runtime/Cargo.lock
Generated
-112
View File
@@ -1,112 +0,0 @@
# This file is automatically @generated by Cargo.
# It is not intended for manual editing.
version = 4
[[package]]
name = "allocator-api2"
version = "0.2.21"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "683d7910e743518b0e34f1186f92494becacb047c7b6bf616c96772180fef923"
[[package]]
name = "bdwgc-alloc"
version = "0.6.13"
source = "git+https://git.deertopia.net/msyds/bdwgc-rust.git#ccc273a168f3ddfee0a2ae170f561f19da8c274a"
dependencies = [
"cmake",
"libc",
]
[[package]]
name = "cc"
version = "1.2.62"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "a1dce859f0832a7d088c4f1119888ab94ef4b5d6795d1ce05afb7fe159d79f98"
dependencies = [
"find-msvc-tools",
"shlex",
]
[[package]]
name = "cmake"
version = "0.1.58"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "c0f78a02292a74a88ac736019ab962ece0bc380e3f977bf72e376c5d78ff0678"
dependencies = [
"cc",
]
[[package]]
name = "const_panic"
version = "0.2.15"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "e262cdaac42494e3ae34c43969f9cdeb7da178bdb4b66fa6a1ea2edb4c8ae652"
dependencies = [
"typewit",
]
[[package]]
name = "equivalent"
version = "1.0.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "877a4ace8713b0bcf2a4e7eec82529c029f1d0619886d18145fea96c3ffe5c0f"
[[package]]
name = "find-msvc-tools"
version = "0.1.9"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "5baebc0774151f905a1a2cc41989300b1e6fbb29aff0ceffa1064fdd3088d582"
[[package]]
name = "foldhash"
version = "0.1.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "d9c4f5dac5e15c24eb999c26181a6ca40b39fe946cbe4c263c7209467bc83af2"
[[package]]
name = "gyehoek"
version = "0.1.0"
dependencies = [
"bdwgc-alloc",
"const_panic",
"internment",
"libc",
]
[[package]]
name = "hashbrown"
version = "0.15.5"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "9229cfe53dfd69f0609a49f65461bd93001ea1ef889cd5529dd176593f5338a1"
dependencies = [
"allocator-api2",
"equivalent",
"foldhash",
]
[[package]]
name = "internment"
version = "0.8.6"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "636d4b0f6a39fd684effe2a73f5310df16a3fa7954c26d36833e98f44d1977a2"
dependencies = [
"hashbrown",
]
[[package]]
name = "libc"
version = "0.2.186"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "68ab91017fe16c622486840e4c83c9a37afeff978bd239b5293d61ece587de66"
[[package]]
name = "shlex"
version = "1.3.0"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "0fda2ff0d084019ba4d7c6f371c95d8fd75ce3524c3cb8fb653a3023f6323e64"
[[package]]
name = "typewit"
version = "1.15.2"
source = "registry+https://github.com/rust-lang/crates.io-index"
checksum = "214ca0b2191785cbc06209b9ca1861e048e39b5ba33574b3cedd58363d5bb5f6"
runtime/Cargo.toml
-20
View File
@@ -1,20 +0,0 @@
[package]
name = "gyehoek"
version = "0.1.0"
edition = "2024"
[lib]
name = "gyehoek"
# crate-type = ["cdylib"]
crate-type = ["staticlib"]
[dependencies]
bdwgc-alloc = { version = "0.6.13"
, default-features = false
, features = ["cmake"] }
const_panic = "0.2.15"
internment = "0.8.6"
libc = "0.2.186"
[patch.crates-io]
bdwgc-alloc = { git = 'https://git.deertopia.net/msyds/bdwgc-rust.git' }
runtime/default.nix
-24
View File
@@ -1,24 +0,0 @@
{ lib
, rustPlatform
, bdwgc
, cmake
, pkg-config
}:
rustPlatform.buildRustPackage (finalAttrs: {
pname = "gyehoek-runtime";
version = "0.0.1";
src = ./.;
cargoLock = {
lockFile = ./Cargo.lock;
outputHashes."bdwgc-alloc-0.6.13" =
"sha256-8/EZ9FThVVsdkwB+OIlNHQJxIr6DPf701Mlfq5U1j4E=";
};
nativeBuildInputs = [
pkg-config
cmake
];
buildInputs = [
bdwgc
];
})
runtime/src/capi.rs
-24
View File
@@ -1,24 +0,0 @@
use std::slice;
use crate::scm::scm_bits;
use crate::scm;
#[unsafe(no_mangle)]
pub extern "C" fn scm_from_utf8_string (
ptr : *const u8,
len : usize
) -> scm_bits {
let bytes = unsafe { slice::from_raw_parts (ptr, len) };
scm::make_string (str::from_utf8 (bytes).unwrap ())
}
// #[unsafe(no_mangle)]
// pub extern "C" fn scm_hash (ptr : *const u8, len : usize) -> u64 {
// let bytes = unsafe { slice::from_raw_parts (ptr, len) };
// crate::obarray::hash (str::from_utf8 (bytes).unwrap ())
// }
#[unsafe(no_mangle)]
pub extern "C" fn scm_string_to_symbol (str : scm_bits) -> scm_bits {
crate::scm::string_to_symbol (str)
}
runtime/src/gc.rs
-34
View File
@@ -1,34 +0,0 @@
use libc::{c_void, size_t};
#[link(name = "gc", kind = "static")]
unsafe extern "C" {
// fn GC_allow_register_threads ();
// fn GC_alloc_lock ();
// fn GC_alloc_unlock ();
// fn GC_free (ptr: *mut c_void);
// fn GC_get_stack_base (stack_base: *mut GcStackBase) -> c_int;
// fn GC_init ();
fn GC_malloc (size: size_t) -> *mut c_void;
fn GC_realloc (ptr: *mut c_void, size: size_t) -> *mut c_void;
// fn GC_register_my_thread
// (stack_base: *const GcStackBase) -> c_int;
// fn GC_set_stackbottom
// (thread: *const c_void, stack_bottom: *const GcStackBase);
// fn GC_unregister_my_thread ();
// fn GC_gcollect ();
// fn GC_register_finalizer (
// ptr: *const c_void,
// finalizer: extern "C" fn (*mut c_void, *mut c_void),
// client_data: *const c_void,
// opt_old_finalizer: *const c_void,
// opt_old_client_data: *const c_void,
// ) -> *mut c_void;
}
pub unsafe fn malloc<T> (size: usize) -> *mut T {
unsafe { GC_malloc (size) as *mut T }
}
pub unsafe fn realloc<T> (ptr: *mut T, size: usize) -> *mut T {
unsafe { GC_realloc (ptr as *mut c_void, size) as *mut T }
}
runtime/src/lib.rs
-9
View File
@@ -1,9 +0,0 @@
#![allow(non_upper_case_globals)]
#![allow(non_camel_case_types)]
mod gc;
mod scm;
mod primitives;
// mod obarray;
mod capi;
mod var;
runtime/src/primitives.rs
-31
View File
@@ -1,31 +0,0 @@
use crate::scm;
use crate::scm::{scm_bits, SCM};
use std::io::{stdout, Write};
#[unsafe(no_mangle)]
pub extern "C" fn scm_write (x: scm_bits) -> scm_bits {
match scm::unpack (x) {
SCM::SmallInt (n) => print! ("{n}"),
SCM::Cons (car, cdr) => {
print! ("(");
scm_write (car);
print! (" . ");
scm_write (cdr);
print! (")");
},
SCM::String (s) => print! ("\"{s}\""),
SCM::Nil => print! ("()"),
SCM::False => print! ("#f"),
SCM::True => print! ("#t"),
SCM::Symbol (_s) => print! ("{x:#016x}"),
// SCM::Symbol (s) => print! ("{s}"),
};
let _ = stdout ().flush ();
return 0;
}
#[unsafe(no_mangle)]
pub extern "C" fn scm_newline () -> scm_bits {
print! ("\n");
0
}
runtime/src/scm.rs
-203
View File
@@ -1,203 +0,0 @@
#![allow(non_upper_case_globals)]
#![allow(non_camel_case_types)]
use std::slice;
use internment::Intern;
use crate::gc;
pub type scm_bits = u64;
pub const tc2_int : u64 = 2;
pub const tc3_cons : u64 = 0;
pub const tc7_obarray : u64 = 0x55;
pub const tc7_symbol : u64 = 0x05;
pub const tc7_string : u64 = 0x15;
// pub const scm_false : SCM = pack (0b00100);
// pub const scm_true : SCM = pack (0b01100);
// pub const scm_eol : SCM = pack (0b10100);
pub enum SCM {
SmallInt (i64),
Cons (scm_bits, scm_bits),
String (String),
Symbol (String),
Nil,
False,
True,
}
// #[inline(always)]
// pub fn pack (x : SCM) -> scm_bits {
// }
#[inline(always)]
pub fn unpack_string (x : scm_bits) -> String {
let len = unsafe { cell_word (x, 1) };
let str_beginning = (x as *const scm_bits).wrapping_add (2) as *const u8;
let slice = unsafe {
str::from_utf8 (
slice::from_raw_parts (
str_beginning,
len.try_into ().unwrap ()
)
).unwrap ()
};
String::from (slice)
}
// super duper important for this to inline. we want to eliminate the
// SCM type at runtime as much as possible. the hope is for inlining
// to lead to a case-of-case–esque transformation.
#[inline(always)]
pub fn unpack (x : scm_bits) -> SCM {
if is_small_int (x) {
SCM::SmallInt ((x >> 2) as i64)
} else if is_cons (x) {
// `car` x and `cdr` x are safe iff `is_cons` x.
unsafe { SCM::Cons (car (x), cdr (x)) }
} else if is_string (x) {
SCM::String (unpack_string (x))
} else if is_symbol (x) {
let s = unpack_string (unsafe { cell_word (x, 1) });
SCM::Symbol (s)
} else {
// concat_panic! ("don't know how to unpack: ", x)
panic! ("don't know how to unpack {x:#016x}")
}
}
const fn is_small_int (x: scm_bits) -> bool {
3 & x == tc2_int
}
const fn is_immediate (x: scm_bits) -> bool {
6 & x != 0
}
fn is_string (x: scm_bits) -> bool {
has_tc7 (x, tc7_string)
}
fn is_cons (x: scm_bits) -> bool {
// safety of `cell_type` is mutually exclusive with
// `is_immediate`, so this is okay.
unsafe {
! is_immediate (x) && (1 & cell_type (x)) == 0
}
}
fn is_symbol (x : scm_bits) -> bool {
has_tc7 (x, tc7_symbol)
}
fn has_tc7 (x: scm_bits, tc7: u64) -> bool {
unsafe {
! is_immediate (x) && (0x7f & cell_type (x)) == tc7
}
}
unsafe fn cell_type (x: scm_bits) -> scm_bits {
unsafe { cell_word (x, 0) }
}
unsafe fn cell_word (x: scm_bits, n: usize) -> scm_bits {
let p = x as *mut scm_bits;
unsafe {
*(p.wrapping_add (n))
}
}
unsafe fn car (x: scm_bits) -> scm_bits {
unsafe { cell_word (x, 0) }
}
unsafe fn cdr (x: scm_bits) -> scm_bits {
unsafe { cell_word (x, 1) }
}
pub unsafe fn words (tag : scm_bits, n : usize) -> *mut scm_bits {
let r = unsafe { gc::malloc (n * size_of::<scm_bits> ()) };
unsafe { *r = tag };
return r
}
pub fn pack_ptr (obj : *const scm_bits) -> scm_bits {
obj as scm_bits
}
pub unsafe fn set_word (obj : *mut scm_bits, ix : usize, val : scm_bits) {
let x = obj.wrapping_add (ix);
unsafe { *x = val; }
}
pub fn make_string_from_raw_parts (
ptr : *const u8,
len : usize
) -> scm_bits {
let bytes = unsafe { slice::from_raw_parts (ptr, len) };
make_string (str::from_utf8 (bytes).unwrap ())
}
pub fn make_string (s : &str) -> scm_bits {
let len = s.len ();
let size_of_tag_and_len = 2 * size_of::<scm_bits> ();
let size_of_contents = len;
let r = unsafe { gc::malloc (size_of_tag_and_len + size_of_contents) };
unsafe {
set_word (r, 0, tc7_string);
set_word (r, 1, len as u64);
}
let str_beginning = r.wrapping_add (2) as *mut u8;
for (i, b) in s.as_bytes ().iter ().enumerate () {
unsafe { *(str_beginning.wrapping_add (i)) = *b };
}
return pack_ptr (r)
}
// pub fn make_symbol (name : &str) -> scm_bits {
// let r = unsafe { words (tc7_symbol, 2) };
// let sym = obarray::symbols.intern (name).to_usize ();
// unsafe { set_word (r, 1, sym.try_into ().unwrap ()) };
// pack_ptr (r)
// }
struct Symbol ([scm_bits; 2]);
impl PartialEq for Symbol {
fn eq (&self, other: &Self) -> bool {
if let (SCM::String (s1), SCM::String (s2))
= (unpack (self.0[1]), unpack (other.0[1])) {
s1 == s2
} else {
panic! ("not a symbol")
}
}
}
impl Eq for Symbol {}
impl std::hash::Hash for Symbol {
fn hash <H: std::hash::Hasher> (&self, state: &mut H) {
if let SCM::String (s) = unpack (self.0[1]) {
s.hash (state)
} else {
panic! ("not a symbol")
}
}
}
fn make_symbol_off_heap (name : scm_bits) -> Symbol {
Symbol ([ tc7_symbol, name ])
}
pub fn string_to_symbol (str : scm_bits) -> scm_bits {
let r = Intern::new (make_symbol_off_heap (str));
pack_ptr (r.0.as_ptr ())
}
runtime/src/var.rs
-26
View File
@@ -1,26 +0,0 @@
use std::{collections::HashMap, ops::DerefMut as _, sync::{LazyLock, RwLock}};
use crate::scm::scm_bits;
struct Vars (
LazyLock <RwLock <HashMap <String, scm_bits>>>
);
impl Vars {
pub const fn new () -> Vars {
Vars (LazyLock::new (|| RwLock::new (HashMap::new ())))
}
pub fn lookup (&self, name : String) -> Option <scm_bits> {
// let r = self.0.write ().unwrap ();
// (*r).get (&name).map (|x| *x)
todo! ()
}
pub fn define (&self, name : String, value : scm_bits) {
// let mut r = self.0.write ().unwrap ();
// r.deref_mut ().insert (name, value);
todo! ()
}
}
static vars : Vars = Vars::new ();
shake-wrapper.nix
+14
View File
@@ -0,0 +1,14 @@
{ runCommandLocal, makeWrapper, lib, haskellPackages }:
let
our-ghc = haskellPackages.ghc.withPackages (ps: [
ps.shake
]);
in runCommandLocal
"shake-wrapper"
{ nativeBuildInputs = [ makeWrapper ]; }
''
mkdir -p $out/bin
makeWrapper ${lib.getExe haskellPackages.shake} $out/bin/shake \
--prefix PATH : ${lib.makeBinPath [our-ghc]}
''