Cache Pure Top Level Definitions on startup

parser-typechecker/src/Unison/Builtin.hs

@@ -103,7 +103,7 @@ builtinEffectDecls :: [(Symbol, (R.Id, EffectDeclaration))]
 builtinEffectDecls = [(v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinEffectDecls]
 
 codeLookup :: (Applicative m) => CodeLookup Symbol m Ann
-codeLookup = CodeLookup (const $ pure Nothing) $ \r ->
+codeLookup = CodeLookup (const $ pure Nothing) (const $ pure Nothing) $ \r ->
   pure $
     lookup r [(r, Right x) | (r, x) <- snd <$> builtinDataDecls]
       <|> lookup r [(r, Left x) | (r, x) <- snd <$> builtinEffectDecls]

parser-typechecker/src/Unison/Codebase/CodeLookup.hs

@@ -8,38 +8,44 @@ import Unison.Prelude
 import Unison.Reference qualified as Reference
 import Unison.Term (Term)
 import Unison.Term qualified as Term
+import Unison.Type (Type)
 import Unison.Util.Defns (Defns (..))
 import Unison.Util.Set qualified as Set
 import Unison.Var (Var)
 
 data CodeLookup v m a = CodeLookup
   { getTerm :: Reference.Id -> m (Maybe (Term v a)),
+    getTypeOfTerm :: Reference.Id -> m (Maybe (Type v a)),
     getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a))
   }
 
 instance MFunctor (CodeLookup v) where
-  hoist f (CodeLookup tm tp) = CodeLookup (f . tm) (f . tp)
+  hoist f (CodeLookup tm tmTyp tp) = CodeLookup (f . tm) (f . tmTyp) (f . tp)
 
 instance (Ord v, Functor m) => Functor (CodeLookup v m) where
-  fmap f cl = CodeLookup tm ty
+  fmap f cl = CodeLookup tm tmTyp ty
     where
       tm id = fmap (Term.amap f) <$> getTerm cl id
       ty id = fmap md <$> getTypeDeclaration cl id
+      tmTyp id = (fmap . fmap) f <$> getTypeOfTerm cl id
       md (Left e) = Left (f <$> e)
       md (Right d) = Right (f <$> d)
 
 instance (Monad m) => Semigroup (CodeLookup v m a) where
-  c1 <> c2 = CodeLookup tm ty
+  c1 <> c2 = CodeLookup tm tmTyp ty
     where
       tm id = do
         o <- getTerm c1 id
         case o of Nothing -> getTerm c2 id; Just _ -> pure o
+      tmTyp id = do
+        o <- getTypeOfTerm c1 id
+        case o of Nothing -> getTypeOfTerm c2 id; Just _ -> pure o
       ty id = do
         o <- getTypeDeclaration c1 id
         case o of Nothing -> getTypeDeclaration c2 id; Just _ -> pure o
 
 instance (Monad m) => Monoid (CodeLookup v m a) where
-  mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing)
+  mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing) (const $ pure Nothing)
 
 -- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure?
 -- todo: add some tests on this guy?

parser-typechecker/src/Unison/Codebase/CodeLookup/Util.hs

@@ -8,15 +8,18 @@ import Unison.DataDeclaration qualified as DataDeclaration
 import Unison.Prelude
 import Unison.Reference qualified as Reference
 import Unison.Term qualified as Term
+import Unison.Type qualified as Type
 import Unison.UnisonFile qualified as UF
 import Unison.UnisonFile.Type (TypecheckedUnisonFile)
 import Unison.Var (Var)
 
 fromTypecheckedUnisonFile :: forall m v a. (Var v, Monad m) => TypecheckedUnisonFile v a -> CodeLookup v m a
-fromTypecheckedUnisonFile tuf = CodeLookup tm ty
+fromTypecheckedUnisonFile tuf = CodeLookup tm tmTyp ty
   where
     tm :: Reference.Id -> m (Maybe (Term.Term v a))
-    tm id = pure $ Map.lookup id termMap
+    tm id = pure . fmap fst $ Map.lookup id termMap
+    tmTyp :: Reference.Id -> m (Maybe (Type.Type v a))
+    tmTyp id = pure . fmap snd $ Map.lookup id termMap
     ty :: Reference.Id -> m (Maybe (DataDeclaration.Decl v a))
     ty id = pure $ Map.lookup id dataDeclMap <|> Map.lookup id effectDeclMap
     dataDeclMap =
@@ -31,5 +34,5 @@ fromTypecheckedUnisonFile tuf = CodeLookup tm ty
           | (_, (Reference.DerivedId id, ad)) <-
               Map.toList (UF.effectDeclarations' tuf)
         ]
-    termMap :: Map Reference.Id (Term.Term v a)
-    termMap = Map.fromList [(id, tm) | (_a, id, _wk, tm, _tp) <- toList $ UF.hashTermsId tuf]
+    termMap :: Map Reference.Id (Term.Term v a, Type.Type v a)
+    termMap = Map.fromList [(id, (tm, typ)) | (_a, id, _wk, tm, typ) <- toList $ UF.hashTermsId tuf]

parser-typechecker/src/Unison/Util/EnumContainers.hs

@@ -15,6 +15,7 @@ module Unison.Util.EnumContainers
     keysSet,
     restrictKeys,
     withoutKeys,
+    mapDifference,
     member,
     lookup,
     lookupWithDefault,
@@ -118,6 +119,9 @@ restrictKeys (EM m) (ES s) = EM $ IM.restrictKeys m s
 withoutKeys :: (EnumKey k) => EnumMap k a -> EnumSet k -> EnumMap k a
 withoutKeys (EM m) (ES s) = EM $ IM.withoutKeys m s
 
+mapDifference :: (EnumKey k) => EnumMap k a -> EnumMap k b -> EnumMap k a
+mapDifference (EM l) (EM r) = EM $ IM.difference l r
+
 member :: (EnumKey k) => k -> EnumSet k -> Bool
 member e (ES s) = IS.member (keyToInt e) s
 

unison-core/src/Unison/Type.hs

@@ -57,6 +57,9 @@ _Ref = _Ctor @"Ref"
 -- | Types are represented as ABTs over the base functor F, with variables in `v`
 type Type v a = ABT.Term F v a
 
+-- | For use with recursion schemes.
+type TypeF v a r = ABT.Term' F v a r
+
 wrapV :: (Ord v) => Type v a -> Type (ABT.V v) a
 wrapV = ABT.vmap ABT.Bound
 

unison-runtime/package.yaml

@@ -72,6 +72,7 @@ library:
     - unison-pretty-printer
     - unison-syntax
     - unison-util-bytes
+    - unison-util-recursion
     - unliftio
     - vector
     - crypton-x509

unison-runtime/src/Unison/Codebase/Execute.hs

@@ -68,6 +68,10 @@ execute codebase runtime mainPath =
 
 codebaseToCodeLookup :: (MonadIO m) => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
 codebaseToCodeLookup c =
-  CL.CodeLookup (Codebase.runTransaction c . getTerm c) (Codebase.runTransaction c . getTypeDeclaration c)
+  CL.CodeLookup goGetTerm goGetTypeOfTerm goGetTypeDecl
     <> Builtin.codeLookup
     <> IOSource.codeLookupM
+  where
+    goGetTerm = (Codebase.runTransaction c . getTerm c)
+    goGetTypeOfTerm = (Codebase.runTransaction c . getTypeOfTermImpl c)
+    goGetTypeDecl = (Codebase.runTransaction c . getTypeDeclaration c)

unison-runtime/src/Unison/Runtime/Builtin.hs

@@ -2304,7 +2304,7 @@ unitValue :: Closure
 unitValue = Closure.Enum Ty.unitRef 0
 
 natValue :: Word64 -> Closure
-natValue w = Closure.DataU1 Ty.natRef 0 (fromIntegral w)
+natValue w =  Closure.DataU1 Ty.natRef 0 (fromIntegral w)
 
 mkForeignTls ::
   forall a r.
@@ -3156,9 +3156,9 @@ declareForeigns = do
             $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len)
 
   declareForeign Untracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $
-    \(src :: PA.MutableArray PA.RealWorld Closure.RClosure, off, len) ->
+    \(src :: PA.MutableArray PA.RealWorld Closure, off, len) ->
       if len == 0
-        then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 Closure.BlackHole
+        then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 ( Closure.BlackHole)
         else
           checkBounds
             "MutableArray.freeze"
@@ -3173,7 +3173,7 @@ declareForeigns = do
     pure . PA.sizeofByteArray
 
   declareForeign Tracked "IO.array" natToBox . mkForeign $
-    \n -> PA.newArray n (Closure.BlackHole :: Closure.RClosure)
+    \n -> PA.newArray n (Closure.BlackHole :: Closure)
   declareForeign Tracked "IO.arrayOf" boxNatToBox . mkForeign $
     \(v :: Closure, n) -> PA.newArray n v
   declareForeign Tracked "IO.bytearray" natToBox . mkForeign $ PA.newByteArray
@@ -3185,7 +3185,7 @@ declareForeigns = do
       pure arr
 
   declareForeign Untracked "Scope.array" natToBox . mkForeign $
-    \n -> PA.newArray n (Closure.BlackHole :: Closure.RClosure)
+    \n -> PA.newArray n (Closure.BlackHole :: Closure)
   declareForeign Untracked "Scope.arrayOf" boxNatToBox . mkForeign $
     \(v :: Closure, n) -> PA.newArray n v
   declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray

unison-runtime/src/Unison/Runtime/Decompile.hs

@@ -32,10 +32,9 @@ import Unison.Runtime.Foreign
     maybeUnwrapForeign,
   )
 import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef)
-import Unison.Runtime.MCode (CombIx (..), pattern RCombIx, pattern RCombRef)
+import Unison.Runtime.MCode (CombIx (..))
 import Unison.Runtime.Stack
-  ( Closure,
-    GClosure (..),
+  ( Closure (..),
     pattern DataC,
     pattern PApV,
   )
@@ -153,33 +152,34 @@ decompile ::
   (Word64 -> Word64 -> Maybe (Term v ())) ->
   Closure ->
   DecompResult v
-decompile _ _ (DataC rf (maskTags -> ct) [] [])
-  | rf == booleanRef = tag2bool ct
-decompile _ _ (DataC rf (maskTags -> ct) [i] []) =
-  decompileUnboxed rf ct i
-decompile backref topTerms (DataC rf _ [] [b])
-  | rf == anyRef =
-      app () (builtin () "Any.Any") <$> decompile backref topTerms b
-decompile backref topTerms (DataC rf (maskTags -> ct) [] bs) =
-  apps' (con rf ct) <$> traverse (decompile backref topTerms) bs
-decompile backref topTerms (PApV (RCombIx (CIx rf rt k)) [] bs)
-  | rf == Builtin "jumpCont" = err Cont $ bug "<Continuation>"
-  | Builtin nm <- rf =
-      apps' (builtin () nm) <$> traverse (decompile backref topTerms) bs
-  | Just t <- topTerms rt k =
-      Term.etaReduceEtaVars . substitute t
-        <$> traverse (decompile backref topTerms) bs
-  | k > 0,
-    Just _ <- topTerms rt 0 =
-      err (UnkLocal rf k) $ bug "<Unknown>"
-  | otherwise = err (UnkComb rf) $ ref () rf
-decompile _ _ (PAp (RCombRef rf) _ _) =
-  err (BadPAp rf) $ bug "<Unknown>"
-decompile _ _ (DataC rf _ _ _) = err (BadData rf) $ bug "<Data>"
-decompile _ _ BlackHole = err Exn $ bug "<Exception>"
-decompile _ _ (Captured {}) = err Cont $ bug "<Continuation>"
-decompile backref topTerms (Foreign f) =
-  decompileForeign backref topTerms f
+decompile backref topTerms = \case
+  DataC rf (maskTags -> ct) [] []
+    | rf == booleanRef -> tag2bool ct
+  DataC rf (maskTags -> ct) [i] [] ->
+    decompileUnboxed rf ct i
+  (DataC rf _ [] [b])
+    | rf == anyRef ->
+        app () (builtin () "Any.Any") <$> decompile backref topTerms b
+  (DataC rf (maskTags -> ct) [] bs) ->
+    apps' (con rf ct) <$> traverse (decompile backref topTerms) bs
+  (PApV (CIx rf rt k) _ [] bs)
+    | rf == Builtin "jumpCont" -> err Cont $ bug "<Continuation>"
+    | Builtin nm <- rf ->
+        apps' (builtin () nm) <$> traverse (decompile backref topTerms) bs
+    | Just t <- topTerms rt k ->
+        Term.etaReduceEtaVars . substitute t
+          <$> traverse (decompile backref topTerms) bs
+    | k > 0,
+      Just _ <- topTerms rt 0 ->
+        err (UnkLocal rf k) $ bug "<Unknown>"
+    | otherwise -> err (UnkComb rf) $ ref () rf
+  (PAp (CIx rf _ _) _ _ _) ->
+    err (BadPAp rf) $ bug "<Unknown>"
+  (DataC rf _ _ _) -> err (BadData rf) $ bug "<Data>"
+  BlackHole -> err Exn $ bug "<Exception>"
+  (Captured {}) -> err Cont $ bug "<Continuation>"
+  (Foreign f) ->
+    decompileForeign backref topTerms f
 
 tag2bool :: (Var v) => Word64 -> DecompResult v
 tag2bool 0 = pure (boolean () False)

unison-runtime/src/Unison/Runtime/Foreign/Function.hs

@@ -124,7 +124,7 @@ instance ForeignConvention Char where
 
 -- In reality this fixes the type to be 'RClosure', but allows us to defer
 -- the typechecker a bit and avoid a bunch of annoying type annotations.
-instance (GClosure comb ~ Elem 'BX) => ForeignConvention (GClosure comb) where
+instance ForeignConvention Closure where
   readForeign us (i : bs) _ bstk = (us,bs,) <$> peekOff bstk i
   readForeign _ [] _ _ = foreignCCError "Closure"
   writeForeign ustk bstk c = do
@@ -441,7 +441,7 @@ instance ForeignConvention BufferMode where
 
 -- In reality this fixes the type to be 'RClosure', but allows us to defer
 -- the typechecker a bit and avoid a bunch of annoying type annotations.
-instance (GClosure comb ~ Elem 'BX) => ForeignConvention [GClosure comb] where
+instance ForeignConvention [Closure] where
   readForeign us (i : bs) _ bstk =
     (us,bs,) . toList <$> peekOffS bstk i
   readForeign _ _ _ _ = foreignCCError "[Closure]"
@@ -453,23 +453,23 @@ instance ForeignConvention [Foreign] where
   readForeign = readForeignAs (fmap marshalToForeign)
   writeForeign = writeForeignAs (fmap Foreign)
 
-instance ForeignConvention (MVar RClosure) where
+instance ForeignConvention (MVar Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap mvarRef)
 
-instance ForeignConvention (TVar RClosure) where
+instance ForeignConvention (TVar Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap tvarRef)
 
-instance ForeignConvention (IORef RClosure) where
+instance ForeignConvention (IORef Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap refRef)
 
-instance ForeignConvention (Ticket RClosure) where
+instance ForeignConvention (Ticket Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap ticketRef)
 
-instance ForeignConvention (Promise RClosure) where
+instance ForeignConvention (Promise Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap promiseRef)
 
@@ -485,15 +485,15 @@ instance ForeignConvention Foreign where
   readForeign = readForeignAs marshalToForeign
   writeForeign = writeForeignAs Foreign
 
-instance ForeignConvention (PA.MutableArray s RClosure) where
+instance ForeignConvention (PA.MutableArray s Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap marrayRef)
 
 instance ForeignConvention (PA.MutableByteArray s) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef)
 
-instance ForeignConvention (PA.Array RClosure) where
+instance ForeignConvention (PA.Array Closure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap iarrayRef)
 
@@ -505,13 +505,13 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
   readForeign = readForeignBuiltin
   writeForeign = writeForeignBuiltin
 
-fromUnisonPair :: RClosure -> (a, b)
+fromUnisonPair :: Closure -> (a, b)
 fromUnisonPair (DataC _ _ [] [x, DataC _ _ [] [y, _]]) =
   (unwrapForeignClosure x, unwrapForeignClosure y)
 fromUnisonPair _ = error "fromUnisonPair: invalid closure"
 
 toUnisonPair ::
-  (BuiltinForeign a, BuiltinForeign b) => (a, b) -> RClosure
+  (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure
 toUnisonPair (x, y) =
   DataC
     Ty.pairRef
@@ -522,7 +522,7 @@ toUnisonPair (x, y) =
     un = DataC Ty.unitRef 0 [] []
     wr z = Foreign $ wrapBuiltin z
 
-unwrapForeignClosure :: RClosure -> a
+unwrapForeignClosure :: Closure -> a
 unwrapForeignClosure = unwrapForeign . marshalToForeign
 
 instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where