~jojo/Carth

5c16dbd4e9978e0b16238875e6a206ed910b4834 — JoJo 1 year, 1 month ago bab4ce2
Greatly improve performance by "shrinking" Infer.St.substs

Substs were remembered for longer than they had to be, which increased
the size of the Map, which significantly impacted a bunch of
operations like composeSubsts.
3 files changed, 16 insertions(+), 15 deletions(-)

M src/Check.hs
M src/Infer.hs
M src/Subst.hs
M src/Check.hs => src/Check.hs +3 -4
@@ 33,11 33,10 @@ typecheck :: Parsed.Program -> Either TypeErr Checked.Program
typecheck (Parsed.Program defs tdefs externs) = runExcept $ do
    (tdefs', ctors) <- checkTypeDefs tdefs
    externs' <- checkExterns tdefs' externs
    (inferred, substs) <- inferTopDefs tdefs' ctors externs' defs
    let substd = substTopDefs substs inferred
    checkTypeVarsBound substd
    inferred <- inferTopDefs tdefs' ctors externs' defs
    checkTypeVarsBound inferred
    let mTypeDefs = fmap (map (unpos . fst) . snd) tdefs'
    compiled <- compileDecisionTrees mTypeDefs substd
    compiled <- compileDecisionTrees mTypeDefs inferred
    checkMainDefined compiled
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Checked.Program compiled tdefs'' externs')

M src/Infer.hs => src/Infer.hs +12 -7
@@ 9,6 9,7 @@ import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Bifunctor
import Data.Functor
import Data.Graph (SCC(..), stronglyConnComp)
import qualified Data.Map as Map
import Data.Map (Map)


@@ 52,8 53,7 @@ makeLenses ''St
type Infer a = ReaderT Env (StateT St (Except TypeErr)) a


inferTopDefs
    :: TypeDefs -> Ctors -> Externs -> [Parsed.Def] -> Except TypeErr (Defs, Subst)
inferTopDefs :: TypeDefs -> Ctors -> Externs -> [Parsed.Def] -> Except TypeErr Defs
inferTopDefs tdefs ctors externs defs =
    let initEnv = Env { _envTypeDefs = tdefs
                      , _envDefs = builtinVirtuals


@@ 65,8 65,7 @@ inferTopDefs tdefs ctors externs defs =
    inferTopDefs' = do
        let externs' = fmap (first (Forall Set.empty)) externs
        defs'' <- augment envDefs (fmap fst externs') (inferDefs defs)
        s <- use substs
        pure (defs'', s)
        pure defs''

checkType :: SrcPos -> Parsed.Type -> Infer Type
checkType pos t = view envTypeDefs >>= \tds -> checkType' tds pos t


@@ 126,9 125,15 @@ inferDefsComponents = flip foldr (pure (Topo [])) $ \scc inferRest -> do
    pure (Topo (def : rest))
  where
    inferComponent :: SCC Parsed.Def -> Infer Def
    inferComponent = \case
        AcyclicSCC vert -> fmap VarDef (inferVarDef vert)
        CyclicSCC verts -> fmap RecDefs (inferRecDefs verts)
    inferComponent d = do
        -- TODO: Why is this fine even when we're in a LetRec? Seems like it would mess
        --       things up seriously? Or do I just not cover any cases like this in my
        --       tests?
        assign substs Map.empty
        d' <- case d of
            AcyclicSCC vert -> fmap VarDef (inferVarDef vert)
            CyclicSCC verts -> fmap RecDefs (inferRecDefs verts)
        use substs <&> \s -> substDef s d'

inferVarDef :: Parsed.Def -> Infer VarDef
inferRecDefs :: [Parsed.Def] -> Infer RecDefs

M src/Subst.hs => src/Subst.hs +1 -4
@@ 1,13 1,12 @@
{-# LANGUAGE LambdaCase #-}

module Subst (Subst, subst, substTopDefs, substPat, composeSubsts) where
module Subst (Subst, subst, substDef, composeSubsts) where

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

import Misc
import SrcPos
import Inferred



@@ 15,8 14,6 @@ import Inferred
-- | Map of substitutions from type-variables to more specific types
type Subst = Map TVar Type

substTopDefs :: Subst -> Defs -> Defs
substTopDefs s (Topo defs) = Topo (map (substDef s) defs)

substDef :: Subst -> Def -> Def
substDef s = \case