diff --git a/builder/src/File.hs b/builder/src/File.hs index 7a23bac26..e157ae25b 100644 --- a/builder/src/File.hs +++ b/builder/src/File.hs @@ -11,6 +11,7 @@ module File , exists , remove , removeDir + , getFileTimings ) where @@ -18,6 +19,8 @@ module File import qualified Codec.Archive.Zip as Zip import Control.Exception (catch) import qualified Data.Binary as Binary +import qualified System.IO.Unsafe as Unsafe +import qualified Data.IORef as IORef import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS import qualified Data.ByteString.Builder as B @@ -35,6 +38,7 @@ import qualified System.IO as IO import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError) +import qualified Ext.Common as Ext import Lamdera ((&), alternativeImplementation) -- TIME @@ -65,16 +69,53 @@ instance Binary.Binary Time where -- BINARY +{-# NOINLINE writeNanos #-} +writeNanos :: IORef.IORef Integer +writeNanos = Unsafe.unsafePerformIO (IORef.newIORef 0) + +{-# NOINLINE readNanos #-} +readNanos :: IORef.IORef Integer +readNanos = Unsafe.unsafePerformIO (IORef.newIORef 0) + +{-# NOINLINE timingEnabled #-} +timingEnabled :: Bool +timingEnabled = Ext.envFlag "LDEBUG_FILE_TIMING" + + +timeIt :: IORef.IORef Integer -> IO a -> IO a +timeIt ref action = + if timingEnabled + then do + t0 <- Time.getCurrentTime + result <- action + t1 <- Time.getCurrentTime + let dt = Time.diffUTCTime t1 t0 + nanos = round (realToFrac dt * 1e9 :: Double) :: Integer + IORef.atomicModifyIORef' ref (\acc -> (acc + nanos, ())) + return result + else action + + +-- | Get accumulated write/read times in milliseconds (for reporting). +getFileTimings :: IO (Double, Double) +getFileTimings = do + w <- IORef.readIORef writeNanos + r <- IORef.readIORef readNanos + return (fromIntegral w / 1e6, fromIntegral r / 1e6) + + writeBinary :: (Binary.Binary a) => FilePath -> a -> IO () writeBinary path value = - do let dir = FP.dropFileName path + timeIt writeNanos $ do + let dir = FP.dropFileName path Dir.createDirectoryIfMissing True dir Binary.encodeFile path value readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a) readBinary path = - do pathExists <- Dir.doesFileExist path + timeIt readNanos $ do + pathExists <- Dir.doesFileExist path if pathExists then do result <- Binary.decodeFileOrFail path diff --git a/builder/src/Reporting.hs b/builder/src/Reporting.hs index ea1c88d2f..e5b3f4e44 100644 --- a/builder/src/Reporting.hs +++ b/builder/src/Reporting.hs @@ -36,6 +36,9 @@ import qualified System.Exit as Exit import qualified System.Info as Info import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) +import qualified File +import qualified Elm.Interface as I + import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg import qualified Elm.Version as V @@ -347,14 +350,22 @@ buildLoop chan done = buildLoop chan done1 Right result -> - let - !message = toFinalMessage done result - !width = 12 + length (show done) - in - Lamdera.atomicPutStrLn $ - if length message < width - then '\r' : replicate width ' ' ++ '\r' : message - else '\r' : message + do (writeMs, readMs) <- File.getFileTimings + buildPoolMs <- I.getDedupTimings + let + !message = toFinalMessage done result + !width = 12 + length (show done) + Lamdera.atomicPutStrLn $ + if length message < width + then '\r' : replicate width ' ' ++ '\r' : message + else '\r' : message + when (writeMs > 0 || readMs > 0) $ + Lamdera.atomicPutStrLn $ + "[FILE-TIMING] writeBinary=" ++ show writeMs + ++ "ms readBinary=" ++ show readMs ++ "ms" + when (buildPoolMs > 0) $ + Lamdera.atomicPutStrLn $ + "[DEDUP-TIMING] buildPool=" ++ show buildPoolMs ++ "ms" toFinalMessage :: Int -> BResult a -> [Char] diff --git a/compiler/src/Elm/Interface.hs b/compiler/src/Elm/Interface.hs index b34850be6..ec5c8d5e8 100644 --- a/compiler/src/Elm/Interface.hs +++ b/compiler/src/Elm/Interface.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE BangPatterns #-} module Elm.Interface ( Interface(..) , Union(..) @@ -13,20 +14,29 @@ module Elm.Interface , privatize , extractUnion , extractAlias + , getDedupTimings ) where import Control.Monad (liftM, liftM3, liftM4, liftM5) import Data.Binary +import Data.Binary.Put (putWord32le) +import Data.Binary.Get (getWord32le, lookAhead) +import qualified Data.IORef as IORef +import qualified Data.Time.Clock as Clock +import qualified System.IO.Unsafe as Unsafe import Data.Map.Strict ((!)) import qualified Data.Map.Strict as Map import qualified Data.Map.Merge.Strict as Map +import qualified Data.IntMap.Strict as IntMap import qualified Data.Name as Name import qualified AST.Canonical as Can import qualified AST.Utils.Binop as Binop +import qualified Elm.ModuleName as ModuleName import qualified Elm.Package as Pkg +import qualified Ext.Common as Ext import qualified Reporting.Annotation as A @@ -198,8 +208,19 @@ privatize di = instance Binary Interface where - get = liftM5 Interface get get get get get - put (Interface a b c d e) = put a >> put b >> put c >> put d >> put e + put iface = do + putWord8 0x00 -- magic sentinel: new dedup format + putInterfaceDedup iface + + get = do + firstByte <- lookAhead getWord8 + if firstByte == 0x00 + then do + _ <- getWord8 -- consume magic sentinel + getInterfaceDedup + else + -- old format: fall back to standard deserialization + liftM5 Interface get get get get get instance Binary Union where @@ -219,8 +240,8 @@ instance Binary Union where instance Binary Alias where - put union = - case union of + put iAlias = + case iAlias of PublicAlias a -> putWord8 0 >> put a PrivateAlias a -> putWord8 1 >> put a @@ -233,16 +254,17 @@ instance Binary Alias where instance Binary Binop where - get = - liftM4 Binop get get get get + get = do + n <- get; a <- get; s <- get; p <- get + return (Binop n a s p) put (Binop a b c d) = put a >> put b >> put c >> put d instance Binary DependencyInterface where - put union = - case union of + put depIface = + case depIface of Public a -> putWord8 0 >> put a Private a b c -> putWord8 1 >> put a >> put b >> put c @@ -252,3 +274,491 @@ instance Binary DependencyInterface where 0 -> liftM Public get 1 -> liftM3 Private get get get _ -> fail "binary encoding of DependencyInterface was corrupted" + + + +-- ============================================================================ +-- TYPE DEDUPLICATION (Shape-based bottom-up interning) +-- +-- Each Can.Type subtree gets interned into a "Shape" where children are +-- already Word32 pool IDs. Hashing/comparing a Shape is O(small) regardless +-- of subtree size, so the Map.lookup that gates dedup is never expensive. +-- We thread an InternState through the walk; top-level values produce Put +-- actions that reference children by ID (no re-lookup phase required). +-- ============================================================================ + + +data Shape + = SLambda !Word32 !Word32 + | SVar !Name.Name + | SType !ModuleName.Canonical !Name.Name ![Word32] + | SRecord ![(Name.Name, Word16, Word32)] !(Maybe Name.Name) + | SUnit + | STuple !Word32 !Word32 !(Maybe Word32) + | SAlias !ModuleName.Canonical !Name.Name ![(Name.Name, Word32)] !ShapeAlias + deriving (Eq, Ord) + + +data ShapeAlias = SHoley !Word32 | SFilled !Word32 + deriving (Eq, Ord) + + +type ShapePool = Map.Map Shape Word32 +type TypeTable = IntMap.IntMap Can.Type + + +data InternState = InternState + { _pool :: !ShapePool + , _list :: ![Shape] -- in reverse insertion order + , _size :: !Word32 + } + + +emptyIntern :: InternState +emptyIntern = InternState Map.empty [] 0 + + +-- Intern a type bottom-up, returning its pool ID. +internType :: Can.Type -> InternState -> (Word32, InternState) +internType tipe state = case tipe of + Can.TLambda a b -> + let (idA, s1) = internType a state + (idB, s2) = internType b s1 + in registerShape (SLambda idA idB) s2 + + Can.TVar n -> + registerShape (SVar n) state + + Can.TType home name ts -> + let (ids, s1) = internTypes ts state + in registerShape (SType home name ids) s1 + + Can.TRecord fields ext -> + let (entries, s1) = internRecordFields (Map.toAscList fields) state + in registerShape (SRecord entries ext) s1 + + Can.TUnit -> + registerShape SUnit state + + Can.TTuple a b mc -> + let (idA, s1) = internType a state + (idB, s2) = internType b s1 + in case mc of + Nothing -> + registerShape (STuple idA idB Nothing) s2 + Just c -> + let (idC, s3) = internType c s2 + in registerShape (STuple idA idB (Just idC)) s3 + + Can.TAlias home name args aliasType -> + let (argEntries, s1) = internAliasArgs args state + in case aliasType of + Can.Holey t -> + let (idT, s2) = internType t s1 + in registerShape (SAlias home name argEntries (SHoley idT)) s2 + Can.Filled t -> + let (idT, s2) = internType t s1 + in registerShape (SAlias home name argEntries (SFilled idT)) s2 + + +-- Direct recursion is measurably faster than mapAccumL here because the +-- intermediate (acc, x) tuples mapAccumL builds in a generic shape add GC +-- pressure on the hot pool-building path. + +internTypes :: [Can.Type] -> InternState -> ([Word32], InternState) +internTypes ts state = + case ts of + [] -> ([], state) + t : rest -> + let (i, s1) = internType t state + (is, s2) = internTypes rest s1 + in (i : is, s2) + + +internRecordFields :: [(Name.Name, Can.FieldType)] -> InternState + -> ([(Name.Name, Word16, Word32)], InternState) +internRecordFields fs state = + case fs of + [] -> ([], state) + (n, Can.FieldType o t) : rest -> + let (i, s1) = internType t state + (rs, s2) = internRecordFields rest s1 + in ((n, o, i) : rs, s2) + + +internAliasArgs :: [(Name.Name, Can.Type)] -> InternState + -> ([(Name.Name, Word32)], InternState) +internAliasArgs args state = + case args of + [] -> ([], state) + (n, t) : rest -> + let (i, s1) = internType t state + (rs, s2) = internAliasArgs rest s1 + in ((n, i) : rs, s2) + + +registerShape :: Shape -> InternState -> (Word32, InternState) +registerShape shape state = + case Map.lookup shape (_pool state) of + Just idx -> (idx, state) + Nothing -> + let !idx = _size state + !pool' = Map.insert shape idx (_pool state) + !size' = idx + 1 + in (idx, InternState pool' (shape : _list state) size') + + + +-- INTERN + COLLECT PUT ACTIONS +-- +-- Each top-level structure (Annotation, Union, Alias, Binop) is interned +-- and converted to a Put action that uses the resulting Word32 IDs. +-- The Put action is closed over the IDs directly, so serialization needs +-- no second lookup. + + +internAnnotationP :: Can.Annotation -> InternState -> (Put, InternState) +internAnnotationP (Can.Forall freeVars tipe) state = + let (idx, s') = internType tipe state + p = put freeVars >> putWord32le idx + in (p, s') + + +internUnionP :: Union -> InternState -> (Put, InternState) +internUnionP iUnion state = + case iUnion of + OpenUnion u -> let (p, s') = internCanUnionP u state in (putWord8 0 >> p, s') + ClosedUnion u -> let (p, s') = internCanUnionP u state in (putWord8 1 >> p, s') + PrivateUnion u -> let (p, s') = internCanUnionP u state in (putWord8 2 >> p, s') + + +internCanUnionP :: Can.Union -> InternState -> (Put, InternState) +internCanUnionP (Can.Union vars ctors numAlts opts) state = + let (ctorPuts, state') = internCtorsP ctors state + p = do put vars + put (length ctors) + sequence_ ctorPuts + put numAlts + put opts + in (p, state') + + +internCtorsP :: [Can.Ctor] -> InternState -> ([Put], InternState) +internCtorsP cs state = + case cs of + [] -> ([], state) + Can.Ctor n idx numArgs ts : rest -> + let (ids, s1) = internTypes ts state + (rs, s2) = internCtorsP rest s1 + p = do put n + put idx + put numArgs + put (length ts) + mapM_ putWord32le ids + in (p : rs, s2) + + +internAliasP :: Alias -> InternState -> (Put, InternState) +internAliasP iAlias state = + case iAlias of + PublicAlias a -> let (p, s') = internCanAliasP a state in (putWord8 0 >> p, s') + PrivateAlias a -> let (p, s') = internCanAliasP a state in (putWord8 1 >> p, s') + + +internCanAliasP :: Can.Alias -> InternState -> (Put, InternState) +internCanAliasP (Can.Alias vars tipe) state = + let (idx, s') = internType tipe state + p = put vars >> putWord32le idx + in (p, s') + + +internBinopP :: Binop -> InternState -> (Put, InternState) +internBinopP (Binop name ann assoc prec) state = + let (annP, s') = internAnnotationP ann state + p = put name >> annP >> put assoc >> put prec + in (p, s') + + +-- Intern the values of a Map, preserving keys; returns ordered (key, putAction) list. +internMapP :: (v -> InternState -> (Put, InternState)) + -> Map.Map k v + -> InternState + -> ([(k, Put)], InternState) +internMapP f m state0 = + let go [] s = ([], s) + go ((k, v) : rest) s = + let (p, s') = f v s + (rs, s'') = go rest s' + in ((k, p) : rs, s'') + in go (Map.toAscList m) state0 + + + +-- SERIALIZE WITH DEDUP + + +{-# NOINLINE buildPoolNanos #-} +buildPoolNanos :: IORef.IORef Integer +buildPoolNanos = Unsafe.unsafePerformIO (IORef.newIORef 0) + + +{-# NOINLINE dedupTimingEnabled #-} +dedupTimingEnabled :: Bool +dedupTimingEnabled = Ext.envFlag "LDEBUG_DEDUP_TIMING" + + +getDedupTimings :: IO Double +getDedupTimings = do + b <- IORef.readIORef buildPoolNanos + return (fromIntegral b / 1e6) + + +putInterfaceDedup :: Interface -> Put +putInterfaceDedup iface = + let (valuesPuts, s1) = internMapP internAnnotationP (_values iface) emptyIntern + (unionsPuts, s2) = internMapP internUnionP (_unions iface) s1 + (aliasesPuts, s3) = internMapP internAliasP (_aliases iface) s2 + (binopsPuts, s4) = internMapP internBinopP (_binops iface) s3 + !state4 = if dedupTimingEnabled then recordPoolTime s4 else s4 + shapes = reverse (_list state4) + in + do putWord32le (_size state4) + mapM_ putShape shapes + put (_home iface) + putMapPuts valuesPuts + putMapPuts unionsPuts + putMapPuts aliasesPuts + putMapPuts binopsPuts + + +-- Force pool construction inside a clock and accumulate the duration. +-- Returns the (forced) state unchanged. +recordPoolTime :: InternState -> InternState +recordPoolTime s = Unsafe.unsafePerformIO $ do + t0 <- Clock.getCurrentTime + _size s `seq` length (_list s) `seq` return () + t1 <- Clock.getCurrentTime + let dt = Clock.diffUTCTime t1 t0 + nanos = round (realToFrac dt * 1e9 :: Double) :: Integer + IORef.atomicModifyIORef' buildPoolNanos (\acc -> (acc + nanos, ())) + return s + + +putMapPuts :: Binary k => [(k, Put)] -> Put +putMapPuts kps = do + put (length kps) + mapM_ (\(k, p) -> put k >> p) kps + + +putShape :: Shape -> Put +putShape shape = case shape of + SLambda a b -> + putWord8 0 >> putWord32le a >> putWord32le b + + SVar name -> + putWord8 1 >> put name + + SRecord fields ext -> + do putWord8 2 + put (length fields) + mapM_ (\(n, o, i) -> put n >> put o >> putWord32le i) fields + put ext + + SUnit -> + putWord8 3 + + STuple a b mc -> + do putWord8 4 + putWord32le a + putWord32le b + case mc of + Nothing -> putWord8 0 + Just c -> putWord8 1 >> putWord32le c + + SAlias home name args aliasType -> + do putWord8 5 + put home + put name + put (length args) + mapM_ (\(n, i) -> put n >> putWord32le i) args + case aliasType of + SHoley i -> putWord8 0 >> putWord32le i + SFilled i -> putWord8 1 >> putWord32le i + + SType home name ts -> + let n = length ts + 7 in + if n <= fromIntegral (maxBound :: Word8) + then do + putWord8 (fromIntegral n) + put home + put name + mapM_ putWord32le ts + else do + putWord8 6 + put home + put name + put (length ts) + mapM_ putWord32le ts + + + +-- DESERIALIZE WITH DEDUP + + +getInterfaceDedup :: Get Interface +getInterfaceDedup = + do poolSize <- getWord32le + table <- readPool poolSize + home <- get + values <- getMapWith (getAnnotationFromPool table) + unions <- getMapWith (getUnionFromPool table) + aliases <- getMapWith (getAliasFromPool table) + binops <- getMapWith (getBinopFromPool table) + return (Interface home values unions aliases binops) + + +readPool :: Word32 -> Get TypeTable +readPool totalSize = go IntMap.empty 0 + where + go table idx + | idx >= totalSize = return table + | otherwise = do + entry <- getPoolEntry table + go (IntMap.insert (fromIntegral idx) entry table) (idx + 1) + + +getPoolEntry :: TypeTable -> Get Can.Type +getPoolEntry table = do + tag <- getWord8 + case tag of + 0 -> Can.TLambda <$> getRefT table <*> getRefT table + + 1 -> Can.TVar <$> get + + 2 -> do + n <- get :: Get Int + pairs <- sequence $ replicate n $ do + name <- get + order <- get + tipe <- getRefT table + return (name, Can.FieldType order tipe) + ext <- get + return (Can.TRecord (Map.fromDistinctAscList pairs) ext) + + 3 -> return Can.TUnit + + 4 -> do + a <- getRefT table + b <- getRefT table + tag2 <- getWord8 + mc <- case tag2 of + 0 -> return Nothing + _ -> Just <$> getRefT table + return (Can.TTuple a b mc) + + 5 -> do + home <- get + name <- get + numArgs <- get :: Get Int + args <- sequence $ replicate numArgs $ do + n <- get + t <- getRefT table + return (n, t) + atag <- getWord8 + aliasType <- case atag of + 0 -> Can.Holey <$> getRefT table + _ -> Can.Filled <$> getRefT table + return (Can.TAlias home name args aliasType) + + 6 -> do + home <- get + name <- get + n <- get :: Get Int + ts <- sequence $ replicate n (getRefT table) + return (Can.TType home name ts) + + n -> do + home <- get + name <- get + ts <- sequence $ replicate (fromIntegral (n - 7)) (getRefT table) + return (Can.TType home name ts) + + +getRefT :: TypeTable -> Get Can.Type +getRefT table = do + idx <- getWord32le + case IntMap.lookup (fromIntegral idx) table of + Just t -> return t + Nothing -> fail "Elm.Interface: invalid type pool index" + + +getAnnotationFromPool :: TypeTable -> Get Can.Annotation +getAnnotationFromPool table = do + freeVars <- get + tipe <- getRefT table + return (Can.Forall freeVars tipe) + + +getUnionFromPool :: TypeTable -> Get Union +getUnionFromPool table = do + tag <- getWord8 + u <- getCanUnionFromPool table + case tag of + 0 -> return (OpenUnion u) + 1 -> return (ClosedUnion u) + _ -> return (PrivateUnion u) + + +getCanUnionFromPool :: TypeTable -> Get Can.Union +getCanUnionFromPool table = do + vars <- get + numCtors <- get :: Get Int + ctors <- sequence $ replicate numCtors $ do + name <- get + idx <- get + numArgs <- get + numTs <- get :: Get Int + ts <- sequence $ replicate numTs (getRefT table) + return (Can.Ctor name idx numArgs ts) + numAlts <- get + opts <- get + return (Can.Union vars ctors numAlts opts) + + +getAliasFromPool :: TypeTable -> Get Alias +getAliasFromPool table = do + tag <- getWord8 + a <- getCanAliasFromPool table + case tag of + 0 -> return (PublicAlias a) + _ -> return (PrivateAlias a) + + +getCanAliasFromPool :: TypeTable -> Get Can.Alias +getCanAliasFromPool table = do + vars <- get + tipe <- getRefT table + return (Can.Alias vars tipe) + + +getBinopFromPool :: TypeTable -> Get Binop +getBinopFromPool table = do + name <- get + ann <- getAnnotationFromPool table + assoc <- get + prec <- get + return (Binop name ann assoc prec) + + + +-- HELPERS + + +getMapWith :: (Binary k, Ord k) => Get v -> Get (Map.Map k v) +getMapWith getValue = do + n <- get :: Get Int + pairs <- sequence $ replicate n $ do + k <- get + v <- getValue + return (k, v) + return (Map.fromList pairs) diff --git a/compiler/src/Type/Solve.hs b/compiler/src/Type/Solve.hs index 252b62e4b..2822a749b 100644 --- a/compiler/src/Type/Solve.hs +++ b/compiler/src/Type/Solve.hs @@ -13,6 +13,7 @@ import qualified Data.Name as Name import qualified Data.NonEmptyList as NE import qualified Data.Vector as Vector import qualified Data.Vector.Mutable as MVector +import qualified Data.IORef as IORef import qualified AST.Canonical as Can import qualified Reporting.Annotation as A @@ -30,12 +31,19 @@ import qualified Type.UnionFind as UF -- RUN SOLVER +-- | Cache for srcTypeToVar to avoid redundant conversion of large monomorphic types +-- (e.g. FrontendModel with 100+ fields appearing in many function signatures). +-- Keyed by (rank, Can.Type). Only used when flexVars is empty (truly monomorphic context). +type SolveCache = IORef.IORef (Map.Map (Int, Can.Type) Variable) + + run :: Constraint -> IO (Either (NE.List Error.Error) (Map.Map Name.Name Can.Annotation)) run constraint = do pools <- MVector.replicate 8 [] + cache <- IORef.newIORef Map.empty (State env _ errors) <- - solve Map.empty outermostRank pools emptyState constraint + solve cache Map.empty outermostRank pools emptyState constraint case errors of [] -> @@ -72,8 +80,8 @@ data State = } -solve :: Env -> Int -> Pools -> State -> Constraint -> IO State -solve env rank pools state constraint = +solve :: SolveCache -> Env -> Int -> Pools -> State -> Constraint -> IO State +solve cache env rank pools state constraint = case constraint of CTrue -> return state @@ -112,7 +120,7 @@ solve env rank pools state constraint = Error.typeReplace expectation expectedType CForeign region name (Can.Forall freeVars srcType) expectation -> - do actual <- srcTypeToVariable rank pools freeVars srcType + do actual <- srcTypeToVariable cache rank pools freeVars srcType expected <- expectedToVariable rank pools expectation answer <- Unify.unify actual expected case answer of @@ -142,17 +150,17 @@ solve env rank pools state constraint = (Error.ptypeReplace expectation expectedType) CAnd constraints -> - foldM (solve env rank pools) state constraints + foldM (solve cache env rank pools) state constraints CLet [] flexs _ headerCon CTrue -> do introduce rank pools flexs - solve env rank pools state headerCon + solve cache env rank pools state headerCon CLet [] [] header headerCon subCon -> - do state1 <- solve env rank pools state headerCon + do state1 <- solve cache env rank pools state headerCon locals <- traverse (A.traverse (typeToVariable rank pools)) header let newEnv = Map.union env (Map.map A.toValue locals) - state2 <- solve newEnv rank pools state1 subCon + state2 <- solve cache newEnv rank pools state1 subCon foldM occurs state2 $ Map.toList locals CLet rigids flexs header headerCon subCon -> @@ -175,7 +183,7 @@ solve env rank pools state constraint = -- run solver in next pool locals <- traverse (A.traverse (typeToVariable nextRank nextPools)) header (State savedEnv mark errors) <- - solve env nextRank nextPools state headerCon + solve cache env nextRank nextPools state headerCon let youngMark = mark let visitMark = nextMark youngMark @@ -190,7 +198,7 @@ solve env rank pools state constraint = let newEnv = Map.union env (Map.map A.toValue locals) let tempState = State savedEnv finalMark errors - newState <- solve newEnv rank nextPools tempState subCon + newState <- solve cache newEnv rank nextPools tempState subCon foldM occurs newState (Map.toList locals) @@ -499,8 +507,8 @@ unit1 = -- SOURCE TYPE TO VARIABLE -srcTypeToVariable :: Int -> Pools -> Map.Map Name.Name () -> Can.Type -> IO Variable -srcTypeToVariable rank pools freeVars srcType = +srcTypeToVariable :: SolveCache -> Int -> Pools -> Map.Map Name.Name () -> Can.Type -> IO Variable +srcTypeToVariable cache rank pools freeVars srcType = let nameToContent name | Name.isNumberType name = FlexSuper Number (Just name) @@ -514,12 +522,33 @@ srcTypeToVariable rank pools freeVars srcType = in do flexVars <- Map.traverseWithKey makeVar freeVars MVector.modify pools (Map.elems flexVars ++) rank - srcTypeToVar rank pools flexVars srcType - - -srcTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable -srcTypeToVar rank pools flexVars srcType = - let go = srcTypeToVar rank pools flexVars in + srcTypeToVar cache rank pools flexVars srcType + + +srcTypeToVar :: SolveCache -> Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable +srcTypeToVar cache rank pools flexVars srcType = + -- Memoize when no flex vars are in scope (truly monomorphic context). + -- This is safe because the resulting Variable depends only on (rank, srcType). + -- Sharing the Variable between call sites is correct: unifications target the + -- shared Variable's descriptor, but for concrete types the descriptor matches + -- everywhere it's used. Free type variables (TVar) would break this, hence the + -- guard on flexVars. + if Map.null flexVars + then do + cached <- IORef.readIORef cache + case Map.lookup (rank, srcType) cached of + Just v -> return v + Nothing -> do + v <- srcTypeToVarReal cache rank pools flexVars srcType + IORef.modifyIORef' cache (Map.insert (rank, srcType) v) + return v + else + srcTypeToVarReal cache rank pools flexVars srcType + + +srcTypeToVarReal :: SolveCache -> Int -> Pools -> Map.Map Name.Name Variable -> Can.Type -> IO Variable +srcTypeToVarReal cache rank pools flexVars srcType = + let go = srcTypeToVar cache rank pools flexVars in case srcType of Can.TLambda argument result -> do argVar <- go argument @@ -534,7 +563,7 @@ srcTypeToVar rank pools flexVars srcType = register rank pools (Structure (App1 home name argVars)) Can.TRecord fields maybeExt -> - do fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields + do fieldVars <- traverse (srcFieldTypeToVar cache rank pools flexVars) fields extVar <- case maybeExt of Nothing -> register rank pools emptyRecord1 @@ -555,7 +584,7 @@ srcTypeToVar rank pools flexVars srcType = aliasVar <- case aliasType of Can.Holey tipe -> - srcTypeToVar rank pools (Map.fromList argVars) tipe + srcTypeToVar cache rank pools (Map.fromList argVars) tipe Can.Filled tipe -> go tipe @@ -563,9 +592,9 @@ srcTypeToVar rank pools flexVars srcType = register rank pools (Alias home name argVars aliasVar) -srcFieldTypeToVar :: Int -> Pools -> Map.Map Name.Name Variable -> Can.FieldType -> IO Variable -srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) = - srcTypeToVar rank pools flexVars srcTipe +srcFieldTypeToVar :: SolveCache -> Int -> Pools -> Map.Map Name.Name Variable -> Can.FieldType -> IO Variable +srcFieldTypeToVar cache rank pools flexVars (Can.FieldType _ srcTipe) = + srcTypeToVar cache rank pools flexVars srcTipe diff --git a/elm.cabal b/elm.cabal index 523840301..28c955ed9 100644 --- a/elm.cabal +++ b/elm.cabal @@ -38,7 +38,7 @@ Executable lamdera ghc-options: -O0 -Wall -Werror else -- Make everything an error, ignoring the ones that already sit in core - ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A128m" + ghc-options: -O2 -rtsopts -threaded "-with-rtsopts=-N -qg -A1g" -Werror -Wno-error=noncanonical-monad-instances -Wno-error=unused-imports diff --git a/ext-common/Ext/Common.hs b/ext-common/Ext/Common.hs index 912aa8b4b..f61482a7e 100644 --- a/ext-common/Ext/Common.hs +++ b/ext-common/Ext/Common.hs @@ -79,6 +79,17 @@ isDebug_ :: Bool isDebug_ = unsafePerformIO $ isDebug +-- Cached presence check for an environment variable. Intended for top-level +-- bindings with a {-# NOINLINE #-} pragma so the env lookup happens once at +-- program start, then the result is reused on every call. +envFlag :: String -> Bool +envFlag name = unsafePerformIO $ do + m <- Env.lookupEnv name + case m of + Just _ -> return True + Nothing -> return False + + isProdEnv = case ostype of MacOS -> False