Merge pull request #5330 from unisonweb/cp/inline-func-calls

Inline code for function calls in interpreter

unison-cli/src/Unison/Main.hs

@@ -234,10 +234,10 @@ main version = do
                 exitError . P.wrap . P.text $
                   "I was unable to parse this file as a compiled\
                   \ program. The parser generated an unrecognized error."
-              Right (Right (v, rf, w, sto))
+              Right (Right (v, rf, combIx, sto))
                 | not vmatch -> mismatchMsg
                 | otherwise ->
-                    withArgs args (RTI.runStandalone sto w) >>= \case
+                    withArgs args (RTI.runStandalone sto combIx) >>= \case
                       Left err -> exitError err
                       Right () -> pure ()
                 where

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

@@ -3156,7 +3156,7 @@ declareForeigns = do
             $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len)
 
   declareForeign Untracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $
-    \(src, off, len) ->
+    \(src :: PA.MutableArray PA.RealWorld Closure.RClosure, off, len) ->
       if len == 0
         then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 Closure.BlackHole
         else
@@ -3173,7 +3173,7 @@ declareForeigns = do
     pure . PA.sizeofByteArray
 
   declareForeign Tracked "IO.array" natToBox . mkForeign $
-    \n -> PA.newArray n Closure.BlackHole
+    \n -> PA.newArray n (Closure.BlackHole :: Closure.RClosure)
   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
+    \n -> PA.newArray n (Closure.BlackHole :: Closure.RClosure)
   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,9 +32,10 @@ import Unison.Runtime.Foreign
     maybeUnwrapForeign,
   )
 import Unison.Runtime.IOSource (iarrayFromListRef, ibarrayFromBytesRef)
-import Unison.Runtime.MCode (CombIx (..))
+import Unison.Runtime.MCode (CombIx (..), pattern RCombIx, pattern RCombRef)
 import Unison.Runtime.Stack
-  ( Closure (..),
+  ( Closure,
+    GClosure (..),
     pattern DataC,
     pattern PApV,
   )
@@ -161,7 +162,7 @@ decompile backref topTerms (DataC rf _ [] [b])
       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 (CIx rf rt k) [] 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
@@ -172,7 +173,7 @@ decompile backref topTerms (PApV (CIx rf rt k) [] bs)
     Just _ <- topTerms rt 0 =
       err (UnkLocal rf k) $ bug "<Unknown>"
   | otherwise = err (UnkComb rf) $ ref () rf
-decompile _ _ (PAp (CIx rf _ _) _ _) =
+decompile _ _ (PAp (RCombRef rf) _ _) =
   err (BadPAp rf) $ bug "<Unknown>"
 decompile _ _ (DataC rf _ _ _) = err (BadData rf) $ bug "<Data>"
 decompile _ _ BlackHole = err Exn $ bug "<Exception>"

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
@@ -121,7 +122,9 @@ instance ForeignConvention Char where
     ustk <- bump ustk
     (ustk, bstk) <$ poke ustk (Char.ord ch)
 
-instance ForeignConvention Closure 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
   readForeign us (i : bs) _ bstk = (us,bs,) <$> peekOff bstk i
   readForeign _ [] _ _ = foreignCCError "Closure"
   writeForeign ustk bstk c = do
@@ -436,7 +439,9 @@ instance ForeignConvention BufferMode where
           ustk <- bump ustk
           (ustk, bstk) <$ poke ustk sblock'buf
 
-instance ForeignConvention [Closure] 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
   readForeign us (i : bs) _ bstk =
     (us,bs,) . toList <$> peekOffS bstk i
   readForeign _ _ _ _ = foreignCCError "[Closure]"
@@ -448,23 +453,23 @@ instance ForeignConvention [Foreign] where
   readForeign = readForeignAs (fmap marshalToForeign)
   writeForeign = writeForeignAs (fmap Foreign)
 
-instance ForeignConvention (MVar Closure) where
+instance ForeignConvention (MVar RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap mvarRef)
 
-instance ForeignConvention (TVar Closure) where
+instance ForeignConvention (TVar RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap tvarRef)
 
-instance ForeignConvention (IORef Closure) where
+instance ForeignConvention (IORef RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap refRef)
 
-instance ForeignConvention (Ticket Closure) where
+instance ForeignConvention (Ticket RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap ticketRef)
 
-instance ForeignConvention (Promise Closure) where
+instance ForeignConvention (Promise RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap promiseRef)
 
@@ -480,15 +485,15 @@ instance ForeignConvention Foreign where
   readForeign = readForeignAs marshalToForeign
   writeForeign = writeForeignAs Foreign
 
-instance ForeignConvention (PA.MutableArray s Closure) where
+instance ForeignConvention (PA.MutableArray s RClosure) 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 Closure) where
+instance ForeignConvention (PA.Array RClosure) where
   readForeign = readForeignAs (unwrapForeign . marshalToForeign)
   writeForeign = writeForeignAs (Foreign . Wrap iarrayRef)
 
@@ -500,13 +505,13 @@ instance {-# OVERLAPPABLE #-} (BuiltinForeign b) => ForeignConvention b where
   readForeign = readForeignBuiltin
   writeForeign = writeForeignBuiltin
 
-fromUnisonPair :: Closure -> (a, b)
+fromUnisonPair :: RClosure -> (a, b)
 fromUnisonPair (DataC _ _ [] [x, DataC _ _ [] [y, _]]) =
   (unwrapForeignClosure x, unwrapForeignClosure y)
 fromUnisonPair _ = error "fromUnisonPair: invalid closure"
 
 toUnisonPair ::
-  (BuiltinForeign a, BuiltinForeign b) => (a, b) -> Closure
+  (BuiltinForeign a, BuiltinForeign b) => (a, b) -> RClosure
 toUnisonPair (x, y) =
   DataC
     Ty.pairRef
@@ -517,7 +522,7 @@ toUnisonPair (x, y) =
     un = DataC Ty.unitRef 0 [] []
     wr z = Foreign $ wrapBuiltin z
 
-unwrapForeignClosure :: Closure -> a
+unwrapForeignClosure :: RClosure -> a
 unwrapForeignClosure = unwrapForeign . marshalToForeign
 
 instance {-# OVERLAPPABLE #-} (BuiltinForeign a, BuiltinForeign b) => ForeignConvention [(a, b)] where

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

@@ -100,14 +100,18 @@ import Unison.Runtime.Decompile
 import Unison.Runtime.Exception
 import Unison.Runtime.MCode
   ( Args (..),
+    CombIx (..),
     Combs,
-    Instr (..),
+    GInstr (..),
+    GSection (..),
+    RCombs,
     RefNums (..),
-    Section (..),
     combDeps,
     combTypes,
     emitComb,
     emptyRNs,
+    rCombIx,
+    resolveCombs,
   )
 import Unison.Runtime.MCode.Serialize
 import Unison.Runtime.Machine
@@ -125,6 +129,7 @@ import Unison.Runtime.Machine
     refNumsTm,
     refNumsTy,
     reifyValue,
+    resolveSection,
   )
 import Unison.Runtime.Pattern
 import Unison.Runtime.Serialize as SER
@@ -659,11 +664,12 @@ interpCompile version ctxVar cl ppe rf path = tryM $ do
   let cc = ccache ctx
       lk m = flip Map.lookup m =<< baseToIntermed ctx rf
   Just w <- lk <$> readTVarIO (refTm cc)
+  let combIx = CIx rf w 0
   sto <- standalone cc w
   BL.writeFile path . runPutL $ do
     serialize $ version
     serialize $ RF.showShort 8 rf
-    putNat w
+    putCombIx combIx
     putStoredCache sto
 
 backrefLifted ::
@@ -989,15 +995,13 @@ evalInContext ppe ctx activeThreads w = do
   pure $ finish result
 
 executeMainComb ::
-  Word64 ->
+  CombIx ->
   CCache ->
   IO (Either (Pretty ColorText) ())
 executeMainComb init cc = do
+  rSection <- resolveSection cc $ Ins (Pack RF.unitRef 0 ZArgs) $ Call True init (BArg1 0)
   result <-
-    UnliftIO.try
-      . eval0 cc Nothing
-      . Ins (Pack RF.unitRef 0 ZArgs)
-      $ Call True init (BArg1 0)
+    UnliftIO.try . eval0 cc Nothing $ rSection
   case result of
     Left err -> Left <$> formatErr err
     Right () -> pure (Right ())
@@ -1119,15 +1123,15 @@ catchInternalErrors sub = sub `UnliftIO.catch` hCE `UnliftIO.catch` hRE
 
 decodeStandalone ::
   BL.ByteString ->
-  Either String (Text, Text, Word64, StoredCache)
+  Either String (Text, Text, CombIx, StoredCache)
 decodeStandalone b = bimap thd thd $ runGetOrFail g b
   where
     thd (_, _, x) = x
     g =
       (,,,)
         <$> deserialize
         <*> deserialize
-        <*> getNat
+        <*> getCombIx
         <*> getStoredCache
 
 -- | Whether the runtime is hosted within a persistent session or as a one-off process.
@@ -1186,10 +1190,12 @@ tryM =
     hRE (PE _ e) = pure $ Just e
     hRE (BU _ _ _) = pure $ Just "impossible"
 
-runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ())
+runStandalone :: StoredCache -> CombIx -> IO (Either (Pretty ColorText) ())
 runStandalone sc init =
   restoreCache sc >>= executeMainComb init
 
+-- | A version of the Code Cache designed to be serialized to disk as
+-- standalone bytecode.
 data StoredCache
   = SCache
       (EnumMap Word64 Combs)
@@ -1205,7 +1211,7 @@ data StoredCache
 
 putStoredCache :: (MonadPut m) => StoredCache -> m ()
 putStoredCache (SCache cs crs trs ftm fty int rtm rty sbs) = do
-  putEnumMap putNat (putEnumMap putNat putComb) cs
+  putEnumMap putNat (putEnumMap putNat (putComb putCombIx)) cs
   putEnumMap putNat putReference crs
   putEnumMap putNat putReference trs
   putNat ftm
@@ -1218,7 +1224,7 @@ putStoredCache (SCache cs crs trs ftm fty int rtm rty sbs) = do
 getStoredCache :: (MonadGet m) => m StoredCache
 getStoredCache =
   SCache
-    <$> getEnumMap getNat (getEnumMap getNat getComb)
+    <$> getEnumMap getNat (getEnumMap getNat (getComb getCombIx))
     <*> getEnumMap getNat getReference
     <*> getEnumMap getNat getReference
     <*> getNat
@@ -1248,7 +1254,7 @@ tabulateErrors errs =
 restoreCache :: StoredCache -> IO CCache
 restoreCache (SCache cs crs trs ftm fty int rtm rty sbs) =
   CCache builtinForeigns False debugText
-    <$> newTVarIO (cs <> combs)
+    <$> newTVarIO combs
     <*> newTVarIO (crs <> builtinTermBackref)
     <*> newTVarIO (trs <> builtinTypeBackref)
     <*> newTVarIO ftm
@@ -1273,22 +1279,23 @@ restoreCache (SCache cs crs trs ftm fty int rtm rty sbs) =
               (debugTextFormat fancy $ pretty PPE.empty dv)
     rns = emptyRNs {dnum = refLookup "ty" builtinTypeNumbering}
     rf k = builtinTermBackref ! k
+    combs :: EnumMap Word64 RCombs
     combs =
-      mapWithKey
-        (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v))
-        numberedTermLookup
+      let builtinCombs = mapWithKey (\k v -> emitComb @Symbol rns (rf k) k mempty (0, v)) numberedTermLookup
+       in builtinCombs <> cs
+            & resolveCombs Nothing
 
 traceNeeded ::
   Word64 ->
-  EnumMap Word64 Combs ->
-  IO (EnumMap Word64 Combs)
+  EnumMap Word64 RCombs ->
+  IO (EnumMap Word64 RCombs)
 traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init
   where
     ks = keysSet numberedTermLookup
     go acc w
       | hasKey w acc = pure acc
       | Just co <- EC.lookup w src =
-          foldlM go (mapInsert w co acc) (foldMap combDeps co)
+          foldlM go (mapInsert w co acc) (foldMap (combDeps . fmap rCombIx) co)
       | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w
 
 buildSCache ::
@@ -1332,7 +1339,7 @@ buildSCache cs crsrc trsrc ftm fty intsrc rtmsrc rtysrc sndbx =
 standalone :: CCache -> Word64 -> IO StoredCache
 standalone cc init =
   buildSCache
-    <$> (readTVarIO (combs cc) >>= traceNeeded init)
+    <$> (readTVarIO (combs cc) >>= traceNeeded init >>= pure . unTieRCombs)
     <*> readTVarIO (combRefs cc)
     <*> readTVarIO (tagRefs cc)
     <*> readTVarIO (freshTm cc)
@@ -1341,3 +1348,6 @@ standalone cc init =
     <*> readTVarIO (refTm cc)
     <*> readTVarIO (refTy cc)
     <*> readTVarIO (sandbox cc)
+  where
+    unTieRCombs :: EnumMap Word64 RCombs -> EnumMap Word64 Combs
+    unTieRCombs = fmap . fmap . fmap $ rCombIx