~jojo/Carth

33b8e29b0a123521c89730fa4b57a190acebe79b — JoJo 30 days ago 6134e25
finish impl lowerDecisionTree with case DSwitchStr
1 files changed, 44 insertions(+), 7 deletions(-)

M src/Back/Lower.hs
M src/Back/Lower.hs => src/Back/Lower.hs +44 -7
@@ 9,6 9,7 @@ import Control.Monad.State
import Control.Monad.Writer
import Data.Bifunctor (bimap)
import Data.Bitraversable
import Data.Either
import Data.Foldable
import Data.Functor
import Data.List


@@ 67,8 68,9 @@ makeLenses ''St

-- data TailPos = TailRet | TailOutParam Low.LocalId | NoTail

newtype Env = Env
data Env = Env
    { _localEnv :: Map TypedVar Low.Operand
    , _globalEnv :: Map TypedVar Low.Global
    }
makeLenses ''Env



@@ 540,10 542,10 @@ lower noGC (Program (Topo defs) datas externs) =


    gcAlloc :: Low.Operand -> Lower Low.Expr
    gcAlloc size = do
    gcAlloc size =
        let fname = if noGC then "malloc" else "GC_malloc"
        f <- view localEnv <&> (Map.! TypedVar fname (Ast.builtinExterns Map.! fname))
        pure $ Low.Expr (Low.Call f [size]) Low.VoidPtr
        in  fromLeft (ice "gcAlloc: (GC_)malloc was a void call")
                <$> callBuiltin fname [size]

    populateCaptures :: [TypedVar] -> Low.Operand -> Lower (Low.Block Low.Operand)
    populateCaptures freeLocals captures = do


@@ 573,6 575,18 @@ lower noGC (Program (Topo defs) datas externs) =
                let n = fromIntegral (Map.size m)
                in  modifying strLits (Map.insert s n) $> n

    lowerStrEq :: Low.Operand -> Low.Operand -> Lower Low.Expr
    lowerStrEq s1 s2 =
        fromLeft (ice "lowerStrEq: str-eq was a void call")
            <$> callBuiltin "str-eq" [s1, s2]

    callBuiltin fname args = do
        gs <- view globalEnv
        let f = Low.OGlobal $ gs Map.! TypedVar fname (Ast.builtinExterns Map.! fname)
        pure $ case returnee (typeof f) of
            Low.RetVal t -> Left (Low.Expr (Low.Call f args) t)
            Low.RetVoid -> Right (Low.VoidCall f args)

    lowerMatch
        :: forall d
         . Destination d


@@ 605,8 619,7 @@ lower noGC (Program (Topo defs) datas externs) =
                selectVarBindings selections bs'
                    `bindrBlockM'` \vars' -> withVars vars' (lowerExpr dest e)
            DSwitch _span selector cases default_ -> do
                -- Type checker wouldn't let us switch on something zero-sized
                selector' <- fromSized <$> lowerAccess selector
                selector' <- lowerSelector selector
                (m, selections') <- select selector' selections
                Low.Block stms tag <- bindrBlockM m $ \m' -> case typeof m' of
                    -- Either a pointer to a struct, representing a tagged union


@@ 629,7 642,28 @@ lower noGC (Program (Topo defs) datas externs) =
                default_' <- lowerDecisionTree selections' default_
                let result = branchToDest dest (Low.BSwitch tag cases' default_')
                pure $ Low.Block stms () `thenBlock` result
            DSwitchStr _selector _cs _def -> undefined
            DSwitchStr selector cases default_ -> do
                selector' <- lowerSelector selector
                ((block, matchee), selections') <-
                    first separateTerm <$> select selector' selections
                let
                    lowerCases = \case
                        [] -> lowerDecisionTree selections' default_
                        (s, dt) : cs -> do
                            s' <- internStr s
                            (block, isMatch) <- fmap separateTerm . emit =<< lowerStrEq
                                matchee
                                (Low.OGlobal s')
                            conseq <- lowerDecisionTree selections' dt
                            alt <- lowerCases cs
                            pure $ block `thenBlock` branchToDest
                                dest
                                (Low.BIf isMatch conseq alt)
                thenBlock block <$> lowerCases (Map.toAscList cases)

        -- Type checker wouldn't let us switch on something zero-sized, so we can
        -- safely unwrap the Sized
        lowerSelector selector = fromSized <$> lowerAccess selector

        select
            :: Low.Access


@@ 988,6 1022,9 @@ mapTerm f b = b { Low.blockTerm = f (Low.blockTerm b) }
dropTerm :: Low.Block a -> Low.Block ()
dropTerm = mapTerm (const ())

separateTerm :: Low.Block a -> (Low.Block (), a)
separateTerm (Low.Block stms term) = (Low.Block stms (), term)

mapBranchTerm :: (a -> b) -> Low.Branch a -> Low.Branch b
mapBranchTerm f = \case
    Low.BIf p c a -> Low.BIf p (mapTerm f c) (mapTerm f a)