diff --git a/codebase2/core/U/Codebase/Reference.hs b/codebase2/core/U/Codebase/Reference.hs index e40ce2ac37..536ebacd5a 100644 --- a/codebase2/core/U/Codebase/Reference.hs +++ b/codebase2/core/U/Codebase/Reference.hs @@ -75,6 +75,7 @@ data Reference' t h = ReferenceBuiltin t | ReferenceDerived (Id' h) deriving stock (Eq, Generic, Functor, Ord, Show) + deriving anyclass (NFData) -- | A type declaration reference. type TermReference' t h = Reference' t h @@ -111,7 +112,8 @@ type Pos = Word64 -- | @Pos@ is a position into a cycle, as cycles are hashed together. data Id' h = Id h Pos - deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData) t_ :: Prism (Reference' t h) (Reference' t' h) t t' t_ = prism ReferenceBuiltin \case diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 690202d366..45721ef039 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -24,6 +24,7 @@ data ABT f v r data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} deriving (Functor, Foldable, Generic, Traversable) + instance (Foldable f, Functor f, forall a. (Eq a) => Eq (f a), Var v) => Eq (Term f v a) where -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable t1 == t2 = go (out t1) (out t2) diff --git a/codebase2/core/Unison/NameSegment/Internal.hs b/codebase2/core/Unison/NameSegment/Internal.hs index 9ecc1ff43b..a1ec7aaeea 100644 --- a/codebase2/core/Unison/NameSegment/Internal.hs +++ b/codebase2/core/Unison/NameSegment/Internal.hs @@ -24,15 +24,16 @@ newtype NameSegment = NameSegment toUnescapedText :: Text } deriving stock (Eq, Generic, Ord, Show) - deriving newtype (Alphabetical) + deriving newtype (Alphabetical, NFData) instance - TypeError - ( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a" - ':$$: 'TypeError.Text "special-cased segment it should exist as a constant in" - ':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via" - ':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”." - ) => + ( TypeError + ( 'TypeError.Text "You cannot implicitly convert a ‘String’ to a ‘NameSegment’. If you need a" + ':$$: 'TypeError.Text "special-cased segment it should exist as a constant in" + ':$$: 'TypeError.Text "“Unison.NameSegment”, otherwise it should be parsed via" + ':$$: 'TypeError.Text "“Unison.Syntax.NameSegment”." + ) + ) => IsString NameSegment where fromString = undefined diff --git a/lib/unison-hash/src/Unison/Hash.hs b/lib/unison-hash/src/Unison/Hash.hs index c6b4b2d67e..e05bdb52bd 100644 --- a/lib/unison-hash/src/Unison/Hash.hs +++ b/lib/unison-hash/src/Unison/Hash.hs @@ -29,13 +29,14 @@ import Unison.Prelude -- | A hash. newtype Hash = Hash {toShort :: ShortByteString} deriving stock (Eq, Ord, Generic) + deriving newtype (NFData) instance Show Hash where show = show . toBase32HexText -- | A hash tagged with the type it's a hash of, useful for maintaining type safety guarantees. newtype HashFor t = HashFor {genericHash :: Hash} - deriving newtype (Show, Eq, Ord, Generic) + deriving newtype (Show, Eq, Ord, Generic, NFData) instance From Hash Text where from = toBase32HexText diff --git a/lib/unison-prelude/package.yaml b/lib/unison-prelude/package.yaml index 2f2ee7d2e3..d5025a55df 100644 --- a/lib/unison-prelude/package.yaml +++ b/lib/unison-prelude/package.yaml @@ -13,6 +13,7 @@ dependencies: - bytestring - containers - directory + - deepseq - generic-lens - either - extra diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index 6bbcaa9cac..e9b1c60762 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -9,17 +9,19 @@ module Unison.Debug debugLog, debugLogM, shouldDebug, + deepEvaluate, DebugFlag (..), ) where import Data.Set qualified as Set import Data.Text qualified as Text -import Debug.Pretty.Simple (pTrace, pTraceM) import System.IO.Unsafe (unsafePerformIO) import Text.Pretty.Simple (pShow) import Unison.Prelude import UnliftIO.Environment (lookupEnv) +import UnliftIO qualified as UnliftIO +import Control.DeepSeq qualified as DeepSeq data DebugFlag = Auth @@ -163,12 +165,12 @@ debugM flag msg a = debugLog :: DebugFlag -> String -> a -> a debugLog flag msg = if shouldDebug flag - then pTrace msg + then trace msg else id debugLogM :: (Monad m) => DebugFlag -> String -> m () debugLogM flag msg = - whenDebug flag $ pTraceM msg + whenDebug flag $ traceM msg -- | A 'when' block which is triggered if the given flag is being debugged. whenDebug :: (Monad m) => DebugFlag -> m () -> m () @@ -193,3 +195,7 @@ shouldDebug = \case PatternCoverageConstraintSolver -> debugPatternCoverageConstraintSolver KindInference -> debugKindInference Update -> debugUpdate + +-- | Evaluate a value to normal form, forcing all thunks, useful when timing things for performance profiling. +deepEvaluate :: (MonadIO m, NFData a) => a -> m a +deepEvaluate a = liftIO . UnliftIO.evaluate $ DeepSeq.force a diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 0ddd4aee64..dd193477ba 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -46,9 +46,14 @@ module Unison.Prelude view, set, over, + + -- * Common Classes + NFData(..), + NFData1(..), ) where +import Control.DeepSeq (NFData(..), NFData1(..)) import Control.Applicative as X import Control.Category as X ((>>>)) import Control.Exception as X (Exception, IOException, SomeException) diff --git a/lib/unison-prelude/src/Unison/Util/Timing.hs b/lib/unison-prelude/src/Unison/Util/Timing.hs index e4ffd5b2a2..3268abcae5 100644 --- a/lib/unison-prelude/src/Unison/Util/Timing.hs +++ b/lib/unison-prelude/src/Unison/Util/Timing.hs @@ -1,17 +1,18 @@ module Unison.Util.Timing ( time, - unsafeTime, + deepTime, ) where +import Control.DeepSeq (NFData) import Data.Time.Clock (picosecondsToDiffTime) import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (diffAbsoluteTime) import System.CPUTime (getCPUTime) -import System.IO.Unsafe (unsafePerformIO) import Unison.Debug qualified as Debug -import UnliftIO (MonadIO, liftIO) +import UnliftIO (MonadIO, evaluate, liftIO) +-- | Time how long it takes to run an action, including evaluating the returned result to WHNF. time :: (MonadIO m) => String -> m a -> m a time label ma = if Debug.shouldDebug Debug.Timing @@ -19,7 +20,7 @@ time label ma = systemStart <- liftIO getSystemTime cpuPicoStart <- liftIO getCPUTime liftIO $ putStrLn $ "Timing " ++ label ++ "..." - a <- ma + a <- ma >>= UnliftIO.evaluate cpuPicoEnd <- liftIO getCPUTime systemEnd <- liftIO getSystemTime let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) @@ -28,19 +29,19 @@ time label ma = pure a else ma --- Mitchell says: this function doesn't look like it would work at all; let's just delete it -unsafeTime :: (Monad m) => String -> m a -> m a -unsafeTime label ma = +-- | Time how long it takes to run an action, including fully evaluating the returned result to normal form. +deepTime :: (MonadIO m) => (NFData a) => String -> m a -> m a +deepTime label ma = if Debug.shouldDebug Debug.Timing then do - let !systemStart = unsafePerformIO getSystemTime - !cpuPicoStart = unsafePerformIO getCPUTime - !_ = unsafePerformIO $ putStrLn $ "Timing " ++ label ++ "..." - a <- ma - let !cpuPicoEnd = unsafePerformIO getCPUTime - !systemEnd = unsafePerformIO getSystemTime + systemStart <- liftIO getSystemTime + cpuPicoStart <- liftIO getCPUTime + liftIO $ putStrLn $ "Timing " ++ label ++ "..." + a <- ma >>= Debug.deepEvaluate + cpuPicoEnd <- liftIO getCPUTime + systemEnd <- liftIO getSystemTime let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) - let !_ = unsafePerformIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" + liftIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" pure a else ma diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 3fdff06aeb..c9731391fe 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -65,6 +65,7 @@ library base , bytestring , containers + , deepseq , directory , either , extra diff --git a/lib/unison-util-bytes/src/Unison/Util/Bytes.hs b/lib/unison-util-bytes/src/Unison/Util/Bytes.hs index 7d4981b89b..f0737651ee 100644 --- a/lib/unison-util-bytes/src/Unison/Util/Bytes.hs +++ b/lib/unison-util-bytes/src/Unison/Util/Bytes.hs @@ -56,7 +56,6 @@ where import Basement.Block.Mutable (Block (Block)) import Codec.Compression.GZip qualified as GZip import Codec.Compression.Zlib qualified as Zlib -import Control.DeepSeq (NFData (..)) import Control.Monad.Primitive (unsafeIOToPrim) import Data.Bits (shiftL, shiftR, (.|.)) import Data.ByteArray qualified as BA diff --git a/parser-typechecker/src/Unison/FileParsers.hs b/parser-typechecker/src/Unison/FileParsers.hs index cc02c9f736..d6d8fe0031 100644 --- a/parser-typechecker/src/Unison/FileParsers.hs +++ b/parser-typechecker/src/Unison/FileParsers.hs @@ -92,14 +92,8 @@ computeTypecheckingEnvironment shouldUseTndr ambientAbilities typeLookupf uf = ShouldUseTndr'Yes parsingEnv -> do let preexistingNames = Parser.names parsingEnv tm = UF.typecheckingTerm uf - possibleDeps = - [ (name, shortname, r) - | (name, r) <- Rel.toList (Names.terms preexistingNames), - v <- Set.toList (Term.freeVars tm), - let shortname = Name.unsafeParseVar v, - name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments shortname) - ] - possibleRefs = Referent.toReference . view _3 <$> possibleDeps + let possibleDeps = findMatchingTermSuffixes (Set.map Name.unsafeParseVar $ Term.freeVars tm) preexistingNames + let possibleRefs = Referent.toReference . view _3 <$> possibleDeps tl <- fmap (UF.declsToTypeLookup uf <>) (typeLookupf (UF.dependencies uf <> Set.fromList possibleRefs)) -- For populating the TDNR environment, we pick definitions -- from the namespace and from the local file whose full name @@ -215,3 +209,34 @@ synthesizeFile env0 uf = do -- Decision Just $ replacement _ -> Nothing + +findMatchingTermSuffixes :: Set Name.Name -> Names.Names -> [(Name.Name, Name.Name, Referent.Referent)] +findMatchingTermSuffixes suffixes names = + findMatchingTermSuffixesHelper (Set.toList suffixes) (Rel.domain $ Names.terms names) + +-- | Efficiently looks up all names which match the provided suffixes in the provided names. +-- +-- >>> import Unison.Syntax.Name qualified as Name +-- >>> import Data.List qualified as List +-- >>> let shortNames = List.sort [Name.unsafeParseText "foo", Name.unsafeParseText "bar.foo", Name.unsafeParseText "quaffle.qux"] +-- >>> let names = Map.fromList [(Name.unsafeParseText "foo", Set.fromList [10, 20]), (Name.unsafeParseText "baz.bar.foo", Set.singleton 2), (Name.unsafeParseText "goose", Set.singleton 3), (Name.unsafeParseText "qux", Set.singleton 4), (Name.unsafeParseText "quaffle.qux", Set.singleton 5)] +-- >>> findMatchingTermSuffixesHelper shortNames names +-- [(Name Relative (NameSegment {toUnescapedText = "foo"} :| []),Name Relative (NameSegment {toUnescapedText = "foo"} :| []),10),(Name Relative (NameSegment {toUnescapedText = "foo"} :| []),Name Relative (NameSegment {toUnescapedText = "foo"} :| []),20),(Name Relative (NameSegment {toUnescapedText = "foo"} :| [NameSegment {toUnescapedText = "bar"},NameSegment {toUnescapedText = "baz"}]),Name Relative (NameSegment {toUnescapedText = "foo"} :| []),2),(Name Relative (NameSegment {toUnescapedText = "foo"} :| [NameSegment {toUnescapedText = "bar"},NameSegment {toUnescapedText = "baz"}]),Name Relative (NameSegment {toUnescapedText = "foo"} :| [NameSegment {toUnescapedText = "bar"}]),2),(Name Relative (NameSegment {toUnescapedText = "qux"} :| [NameSegment {toUnescapedText = "quaffle"}]),Name Relative (NameSegment {toUnescapedText = "qux"} :| [NameSegment {toUnescapedText = "quaffle"}]),5)] +findMatchingTermSuffixesHelper :: (Show r) => [Name.Name {- must be in ascending order -}] -> Map Name.Name (Set r) -> [(Name.Name, Name.Name, r)] +findMatchingTermSuffixesHelper [] _names = [] +findMatchingTermSuffixesHelper (shortName : shortNames) names = + let (_notMatches, possibleMatches) = Map.spanAntitone (\n -> n < shortName) names + (definitelyMatches, notMatches) = Map.spanAntitone (suffixMatchesName shortName) possibleMatches + matchTriples = do + (name, rs) <- Map.toList definitelyMatches + r <- Set.toList rs + pure (name, shortName, r) + in matchTriples + <> + -- There may still be some names in definitelyMatches which match the next shortname depending what it is. + findMatchingTermSuffixesHelper + shortNames + (Map.union definitelyMatches notMatches) + where + suffixMatchesName :: Name.Name -> Name.Name -> Bool + suffixMatchesName suff name = name `Name.endsWithReverseSegments` List.NonEmpty.toList (Name.reverseSegments suff) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index f9c827fda9..61bed39a66 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -28,7 +28,6 @@ import Control.Concurrent as SYS ) import Control.Concurrent.MVar as SYS import Control.Concurrent.STM qualified as STM -import Control.DeepSeq (NFData) import Control.Exception (evaluate) import Control.Exception.Safe qualified as Exception import Control.Monad.Catch (MonadCatch) diff --git a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs index 3c7e9e5239..b045d7a2d4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Slurp.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Slurp.hs @@ -151,7 +151,7 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case -- Get the set of all DIRECT definitions in the file which a definition depends on. codebaseNames :: Names codebaseNames = - Names.filter (`Set.notMember` deprecatedConstructors) unalteredCodebaseNames + Names.withoutTheseNames deprecatedConstructors unalteredCodebaseNames constructorsUnderConsideration :: Set Name constructorsUnderConsideration = Map.toList (UF.dataDeclarationsId' uf) diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 2b8bea50bf..f723b82af0 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -14,6 +14,7 @@ library: - containers >= 0.6.3 - nonempty-containers - cryptonite + - deepseq - either - extra - fuzzyfind diff --git a/unison-core/src/Unison/ConstructorReference.hs b/unison-core/src/Unison/ConstructorReference.hs index 20fc68a9c5..6134bec74a 100644 --- a/unison-core/src/Unison/ConstructorReference.hs +++ b/unison-core/src/Unison/ConstructorReference.hs @@ -14,11 +14,13 @@ import Unison.Reference (TypeReference, TypeReferenceId) import Unison.Reference qualified as Reference import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as ShortHash +import Unison.Prelude -- | A reference to a constructor is represented by a reference to its type declaration, plus the ordinal constructor id. data GConstructorReference r = ConstructorReference !r !ConstructorId - deriving stock (Eq, Functor, Ord, Show) + deriving stock (Eq, Functor, Ord, Show, Generic) + deriving anyclass (NFData) type ConstructorReference = GConstructorReference TypeReference diff --git a/unison-core/src/Unison/ConstructorType.hs b/unison-core/src/Unison/ConstructorType.hs index a0e2b2940b..137f8142a1 100644 --- a/unison-core/src/Unison/ConstructorType.hs +++ b/unison-core/src/Unison/ConstructorType.hs @@ -4,4 +4,6 @@ module Unison.ConstructorType where import Unison.Prelude -data ConstructorType = Data | Effect deriving (Eq, Ord, Show, Enum, Generic) +data ConstructorType = Data | Effect + deriving stock (Eq, Ord, Show, Enum, Generic) + deriving anyclass (NFData) diff --git a/unison-core/src/Unison/Name/Internal.hs b/unison-core/src/Unison/Name/Internal.hs index 3272d43df1..9d4ca80ade 100644 --- a/unison-core/src/Unison/Name/Internal.hs +++ b/unison-core/src/Unison/Name/Internal.hs @@ -33,11 +33,12 @@ import Unison.Util.Alphabetical -- - ".." --> Name Absolute (".." :| []) data Name = Name + -- | whether the name is positioned absolutely (to some arbitrary root namespace), or relatively Position - -- ^ whether the name is positioned absolutely (to some arbitrary root namespace), or relatively + -- | the name segments in reverse order (List.NonEmpty NameSegment) - -- ^ the name segments in reverse order deriving stock (Eq, Generic, Show) + deriving anyclass (NFData) -- | Compare names (kinda) alphabetically: absolute comes before relative, but otherwise compare the name segments -- alphabetically, in order. @@ -49,10 +50,11 @@ instance Alphabetical Name where _ -> compareAlphabetical (segments n1) (segments n2) instance - TypeError - ( 'TypeError.Text - "You cannot make a Name from a string literal because there may (some day) be more than one syntax" - ) => + ( TypeError + ( 'TypeError.Text + "You cannot make a Name from a string literal because there may (some day) be more than one syntax" + ) + ) => IsString Name where fromString = undefined diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index 1897ac1178..a6677915d5 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -12,6 +12,7 @@ module Unison.Names filterByHQs, filterBySHs, filterTypes, + withoutTheseNames, map, makeAbsolute, makeRelative, @@ -93,7 +94,8 @@ data Names = Names { terms :: Relation Name Referent, types :: Relation Name TypeReference } - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + deriving anyclass (NFData) instance Semigroup (Names) where Names e1 t1 <> Names e2 t2 = @@ -542,7 +544,7 @@ lenientToNametree names = (lenientRelationToNametree names.terms) (lenientRelationToNametree names.types) where - lenientRelationToNametree :: Ord a => Relation Name a -> Nametree (Map NameSegment a) + lenientRelationToNametree :: (Ord a) => Relation Name a -> Nametree (Map NameSegment a) lenientRelationToNametree = unflattenNametree . lenientRelationToLeftUniqueRelation @@ -551,3 +553,8 @@ lenientToNametree names = -- The partial `Set.findMin` are fine here because Relation.domain only has non-empty Set values. A NESet would be -- better. BiMultimap.fromRange . Map.map Set.findMin . Relation.domain + +-- | Efficiently remove all instances of the given names from the `Names`. +withoutTheseNames :: Set Name -> Names -> Names +withoutTheseNames ns (Names terms types) = + Names (R.subtractDom ns terms) (R.subtractDom ns types) diff --git a/unison-core/src/Unison/Position.hs b/unison-core/src/Unison/Position.hs index a9264de075..2b284ad5ac 100644 --- a/unison-core/src/Unison/Position.hs +++ b/unison-core/src/Unison/Position.hs @@ -3,8 +3,11 @@ module Unison.Position ) where +import Unison.Prelude + -- | An indicator of whether something is absolute, e.g. ".foo.bar", or relative, e.g. "foo.bar" data Position = Absolute | Relative - deriving stock (Eq, Ord, Show) + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) diff --git a/unison-core/src/Unison/Referent'.hs b/unison-core/src/Unison/Referent'.hs index b65b75e09d..cab1a95142 100644 --- a/unison-core/src/Unison/Referent'.hs +++ b/unison-core/src/Unison/Referent'.hs @@ -35,7 +35,8 @@ import Unison.Prelude -- -- When @Con'@ then @r@ is a type declaration. data Referent' r = Ref' r | Con' (GConstructorReference r) ConstructorType - deriving (Show, Eq, Ord, Functor, Generic) + deriving stock (Show, Eq, Ord, Functor, Generic) + deriving anyclass (NFData) -- | A lens onto the reference in a referent. reference_ :: Lens (Referent' r) (Referent' r') r r' diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index bde4b2a6f7..883f20bccd 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -97,6 +97,7 @@ library , bytestring , containers >=0.6.3 , cryptonite + , deepseq , either , extra , fuzzyfind