Assortment of optimizations

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

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)

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

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

lib/unison-prelude/package.yaml

@@ -13,6 +13,7 @@ dependencies:
   - bytestring
   - containers
   - directory
+  - deepseq
   - generic-lens
   - either
   - extra

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

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)

lib/unison-prelude/src/Unison/Util/Timing.hs

@@ -1,25 +1,26 @@
 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
     then do
       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

lib/unison-prelude/unison-prelude.cabal

@@ -65,6 +65,7 @@ library
       base
     , bytestring
     , containers
+    , deepseq
     , directory
     , either
     , extra

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

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)

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)

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)

unison-core/package.yaml

@@ -14,6 +14,7 @@ library:
     - containers >= 0.6.3
     - nonempty-containers
     - cryptonite
+    - deepseq
     - either
     - extra
     - fuzzyfind

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
 

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)

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

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)

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)

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'