~jojo/Carth

b6516af740c09c150ab6b16630464bc80cbd9399 — JoJo 3 months ago ae1d242
Add class Select

Pass some params implicitly when doing selections
2 files changed, 29 insertions(+), 39 deletions(-)

M src/Codegen.hs
M src/Selections.hs
M src/Codegen.hs => src/Codegen.hs +13 -13
@@ 35,6 35,16 @@ import Selections
import Gen
import Extern

instance Select Gen Val where
    selectAs totVariants ts matchee = do
        tvariant <- fmap typeStruct (lift (genVariantType totVariants ts))
        pGeneric <- getVar matchee
        fmap VVar
             (emitReg "ction_ptr_structural" (bitcast pGeneric (LLType.ptr tvariant)))
    selectSub span' i matchee =
        let tagOffset = if span' > 1 then 1 else 0
        in  genIndexStruct matchee [tagOffset + i]
    selectDeref = genDeref

codegen :: DataLayout -> ShortByteString -> FilePath -> Program -> Either GenErr Module
codegen layout triple moduleFilePath (Program (Topo defs) tdefs externs) = runExcept $ do


@@ 406,12 416,12 @@ genDecisionTree'
    -> Gen a
genDecisionTree' genExpr' genCondBr' genCases' tbody =
    let genDecisionLeaf (bs, e) selections = do
            bs' <- selectVarBindings selAs selSub genDeref selections bs
            bs' <- selectVarBindings selections bs
            withVals bs' (genExpr' e)

        genDecisionSwitchIx selector cs def selections = do
            let (variantIxs, variantDts) = unzip (Map.toAscList cs)
            (m, selections') <- select selAs selSub genDeref selector selections
            (m, selections') <- select selector selections
            mVariantIx <- getLocal =<< case typeOf m of
                IntegerType _ -> pure m
                _ -> genIndexStruct m [0]


@@ 424,7 434,7 @@ genDecisionTree' genExpr' genCondBr' genCases' tbody =
            genCases' tbody selections' variantLs variantDts def

        genDecisionSwitchStr selector cs def selections = do
            (matchee, selections') <- select selAs selSub genDeref selector selections
            (matchee, selections') <- select selector selections
            let cs' = Map.toAscList cs
            let genCase (s, dt) next = do
                    s' <- genStrLit s


@@ 461,16 471,6 @@ genCases tbody selections variantLs variantDts def = do
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi (v : vs)))

selAs :: Span -> [Ast.Type] -> Val -> Gen Val
selAs totVariants ts matchee = do
    tvariant <- fmap typeStruct (lift (genVariantType totVariants ts))
    pGeneric <- getVar matchee
    fmap VVar (emitReg "ction_ptr_structural" (bitcast pGeneric (LLType.ptr tvariant)))

selSub :: Span -> Word32 -> Val -> Gen Val
selSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0 in genIndexStruct matchee [tagOffset + i]

genCtion :: Ast.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    lookupEnum dataType & lift >>= \case

M src/Selections.hs => src/Selections.hs +16 -26
@@ 1,4 1,4 @@
module Selections (Selections, newSelections, select, selectVarBindings) where
module Selections (Select (..), Selections, newSelections, select, selectVarBindings) where

import qualified Data.Map as Map
import Data.Map (Map)


@@ 8,51 8,41 @@ import Control.Monad
import Misc
import Optimized


type Selections a = Map Access a

class Select m a where
    selectAs :: Span -> [Type] -> a -> m a
    selectSub :: Span -> Word32 -> a -> m a
    selectDeref :: a -> m a

newSelections :: a -> Selections a
newSelections x = Map.singleton Obj x

select
    :: (Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Access
    -> Selections a
    -> m (a, Selections a)
select conv sub deref selector selections = case Map.lookup selector selections of
select :: (Monad m, Select m a) => Access -> Selections a -> m (a, Selections a)
select selector selections = case Map.lookup selector selections of
    Just a -> pure (a, selections)
    Nothing -> do
        (a, selections') <- case selector of
            Obj -> ice "select: Obj not in selections"
            As x span' ts -> do
                (a', s') <- select conv sub deref x selections
                a'' <- conv span' ts a'
                (a', s') <- select x selections
                a'' <- selectAs span' ts a'
                pure (a'', s')
            Sel i span' x -> do
                (a', s') <- select conv sub deref x selections
                a'' <- sub span' i a'
                (a', s') <- select x selections
                a'' <- selectSub span' i a'
                pure (a'', s')
            ADeref x -> do
                (a', s') <- select conv sub deref x selections
                a'' <- deref a'
                (a', s') <- select x selections
                a'' <- selectDeref a'
                pure (a'', s')
        pure (a, Map.insert selector a selections')

selectVarBindings
    :: (Monad m)
    => (Span -> [Type] -> a -> m a)
    -> (Span -> Word32 -> a -> m a)
    -> (a -> m a)
    -> Selections a
    -> VarBindings
    -> m [(TypedVar, a)]
selectVarBindings conv sub deref selections = fmap fst . foldM
    :: (Monad m, Select m a) => Selections a -> VarBindings -> m [(TypedVar, a)]
selectVarBindings selections = fmap fst . foldM
    (\(bs', ss) (x, s) -> do
        (a, ss') <- select conv sub deref s ss
        (a, ss') <- select s ss
        pure ((x, a) : bs', ss')
    )
    ([], selections)