-- editorconfig-checker-disable-file
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiWayIf            #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}

-- | Functions for compiling GHC Core expressions into Plutus Core terms.
module PlutusTx.Compiler.Expr (compileExpr, compileExprWithDefs, compileDataConRef) where

import GHC.Builtin.Names qualified as GHC
import GHC.Builtin.Types.Prim qualified as GHC
import GHC.ByteCode.Types qualified as GHC
import GHC.Core qualified as GHC
import GHC.Core.Class qualified as GHC
import GHC.Core.Multiplicity qualified as GHC
import GHC.Core.TyCo.Rep qualified as GHC
import GHC.Plugins qualified as GHC
import GHC.Types.CostCentre qualified as GHC
import GHC.Types.Id.Make qualified as GHC
import GHC.Types.Tickish qualified as GHC
import GHC.Types.TyThing qualified as GHC

#if MIN_VERSION_ghc(9,6,0)
import GHC.Tc.Utils.TcType qualified as GHC
#endif

import PlutusTx.Bool qualified
import PlutusTx.Builtins qualified as Builtins
import PlutusTx.Builtins.Internal qualified as Builtins
import PlutusTx.Compiler.Binders
import PlutusTx.Compiler.Builtins
import PlutusTx.Compiler.Error
import PlutusTx.Compiler.Laziness
import PlutusTx.Compiler.Names
import PlutusTx.Compiler.Trace
import PlutusTx.Compiler.Type
import PlutusTx.Compiler.Types
import PlutusTx.Compiler.Utils
import PlutusTx.Coverage
import PlutusTx.PIRTypes
import PlutusTx.PLCTypes (PLCType, PLCVar)

-- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying
import PlutusTx.Builtins.HasOpaque qualified as Builtins
import PlutusTx.Trace

import PlutusIR qualified as PIR
import PlutusIR.Analysis.Builtins
import PlutusIR.Compiler.Definitions qualified as PIR
import PlutusIR.Compiler.Names (safeFreshName)
import PlutusIR.Core.Type (Term (..))
import PlutusIR.MkPir qualified as PIR
import PlutusIR.Purity qualified as PIR

import PlutusCore qualified as PLC
import PlutusCore.Data qualified as PLC
import PlutusCore.MkPlc qualified as PLC
import PlutusCore.Pretty qualified as PP
import PlutusCore.Subst qualified as PLC

import Control.Lens hiding (index, strict, transform)
import Control.Monad
import Control.Monad.Reader (ask)
import Data.Array qualified as Array
import Data.ByteString qualified as BS
import Data.Generics.Uniplate.Data (transform, universeBi)
import Data.List (elemIndex, isPrefixOf, isSuffixOf)
import Data.Map qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Data.Traversable
import GHC.Num.Integer qualified

{- Note [System FC and System FW]
Haskell uses system FC, which includes type equalities and coercions.

PLC does *not* have coercions in particular. However, PLC also does not have a nominal
type system - everything is constructed via operators on base types, so we have no
need for coercions to convert between newtypes and datatypes.
-}

-- Literals and primitives

{- Note [Literals]
GHC's literals and primitives are a bit of a pain, since they not only have a Literal
containing the actual data, but are wrapped in special functions (often ending in the magic #).

This is a pain to recognize.

Fortunately, in practice the only kind of literals we need to deal with directly are integer literals.
String literals are handled specially, see Note [String literals].
-}

{- Note [unpackFoldrCString#]
This function is introduced by rewrite rules, and usually eliminated by them in concert with `build`.

However, since we often mark things as INLINABLE, we get pre-optimization Core where only the
first transformation has fired. So we need to do something with the function.

- We can't easily turn it into a normal fold expression, since we'd need to make a lambda and
  we're not in 'CoreM' so we can't make fresh names.
- We can't easily translate it to a builtin, since we don't support higher-order functions.

So we use a horrible hack and match on `build . unpackFoldrCString#` to "undo" the original rewrite
rule.
-}

compileLiteral ::
  (CompilingDefault uni fun m ann) =>
  GHC.Literal ->
  m (PIRTerm uni fun)
compileLiteral :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Literal -> m (PIRTerm uni fun)
compileLiteral = \case
  -- Just accept any kind of number literal, we'll complain about types we don't support elsewhere
  (GHC.LitNumber LitNumType
_ Integer
i) -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
Term tyname name uni fun ann -> term ann
PIR.embedTerm (Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun)
-> Term TyName Name DefaultUni DefaultFun Ann -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Ann -> Integer -> Term TyName Name DefaultUni DefaultFun Ann
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline Integer
i
  GHC.LitString ByteString
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal string (maybe you need to use OverloadedStrings)"
  GHC.LitChar Char
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal char"
  GHC.LitFloat Rational
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal float"
  GHC.LitDouble Rational
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal double"
  GHC.LitLabel{} -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal label"
  Literal
GHC.LitNullAddr -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal null"
  GHC.LitRubbish{} -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal rubbish"

-- TODO: this is annoyingly duplicated with the code 'compileExpr', but I failed to unify them since they
-- do different things to the inner expression. This one assumes it's a literal, the other one keeps compiling
-- through it.

-- | Get the bytestring content of a string expression, if possible. Follows (Haskell) variable references!
stringExprContent :: GHC.CoreExpr -> Maybe BS.ByteString
stringExprContent :: CoreExpr -> Maybe ByteString
stringExprContent = \case
  GHC.Lit (GHC.LitString ByteString
bs) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
  -- unpackCString# / unpackCStringUtf8# are just wrappers around a literal
  GHC.Var Id
n `GHC.App` CoreExpr
expr
    | let name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n
    , Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringName Bool -> Bool -> Bool
|| Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringUtf8Name ->
      CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
expr
  -- See Note [unpackFoldrCString#]
  GHC.Var Id
build `GHC.App` CoreExpr
_ `GHC.App` GHC.Lam Id
_ (GHC.Var Id
unpack `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
expr)
    | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
build Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.buildName Bool -> Bool -> Bool
&& Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
unpack Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringFoldrName -> CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
expr
  -- GHC helpfully generates an empty list for the empty string literal instead of a 'LitString'
  GHC.Var Id
nil `GHC.App` GHC.Type (Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe -> Just TyCon
tc)
    | Id
nil Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon -> Id
GHC.dataConWorkId DataCon
GHC.nilDataCon, TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.charTyConName -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
forall a. Monoid a => a
mempty
  -- Chase variable references! GHC likes to lift string constants to variables, that is not good for us!
  GHC.Var (Unfolding -> Maybe CoreExpr
GHC.maybeUnfoldingTemplate (Unfolding -> Maybe CoreExpr)
-> (Id -> Unfolding) -> Id -> Maybe CoreExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unfolding
GHC.realIdUnfolding -> Just CoreExpr
unfolding) -> CoreExpr -> Maybe ByteString
stringExprContent CoreExpr
unfolding
  CoreExpr
_ -> Maybe ByteString
forall a. Maybe a
Nothing

{- | Strip off irrelevant things when we're trying to match a particular pattern in the code. Mostly ticks.
We only need to do this as part of a complex pattern match: if we're just compiling the expression
in question we will strip this off anyway.
-}
strip :: GHC.CoreExpr -> GHC.CoreExpr
strip :: CoreExpr -> CoreExpr
strip = \case
  GHC.Var Id
n `GHC.App` GHC.Type Type
_ `GHC.App` CoreExpr
expr | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.noinlineIdName -> CoreExpr -> CoreExpr
strip CoreExpr
expr
  GHC.Tick CoreTickish
_ CoreExpr
expr                                                                     -> CoreExpr -> CoreExpr
strip CoreExpr
expr
  CoreExpr
expr                                                                                -> CoreExpr
expr

-- | Convert a reference to a data constructor, i.e. a call to it.
compileDataConRef :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRTerm uni fun)
compileDataConRef :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
DataCon -> m (PIRTerm uni fun)
compileDataConRef DataCon
dc = do
  [DataCon]
dcs <- TyCon -> m [DataCon]
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
TyCon -> m [DataCon]
getDataCons TyCon
tc
  [PIRTerm uni fun]
constrs <- TyCon -> m [PIRTerm uni fun]
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
TyCon -> m [PIRTerm uni fun]
getConstructors TyCon
tc

  -- TODO: this is inelegant
  Int
index <- case DataCon -> [DataCon] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex DataCon
dc [DataCon]
dcs of
    Just Int
i -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    Maybe Int
Nothing ->
      Error DefaultUni DefaultFun ann -> m Int
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m Int)
-> Error DefaultUni DefaultFun ann -> m Int
forall a b. (a -> b) -> a -> b
$
        Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"Data constructor not in the type constructor's list of constructors"

  PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ [PIRTerm uni fun]
constrs [PIRTerm uni fun] -> Int -> PIRTerm uni fun
forall a. HasCallStack => [a] -> Int -> a
!! Int
index
  where
    tc :: TyCon
tc = DataCon -> TyCon
GHC.dataConTyCon DataCon
dc

-- | Make alternatives with non-delayed and delayed bodies for a given 'CoreAlt'.
compileAlt ::
  (CompilingDefault uni fun m ann) =>
  -- | The 'CoreAlt' representing the branch itself.
  GHC.CoreAlt ->
  -- | The instantiated type arguments for the data constructor.
  [GHC.Type] ->
  PIRTerm uni fun ->
  -- | Non-delayed and delayed
  m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt (GHC.Alt AltCon
alt [Id]
vars CoreExpr
body) [Type]
instArgTys PIRTerm uni fun
defaultBody =
  Int
-> SDoc
-> m (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
3 (SDoc
"Creating alternative:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> AltCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr AltCon
alt) (m (PIRTerm uni fun, PIRTerm uni fun)
 -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ case AltCon
alt of
    GHC.LitAlt Literal
_ -> Error DefaultUni DefaultFun ann
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann
 -> m (PIRTerm uni fun, PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Literal case"
    -- We just package it up as a lambda bringing all the
    -- vars into scope whose body is the body of the case alternative.
    -- See Note [Iterated abstraction and application]
    -- See Note [Case expressions and laziness]
    GHC.DataAlt DataCon
_ -> [Id]
-> ([VarDecl TyName Name DefaultUni Ann]
    -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
[Id] -> ([VarDecl TyName Name uni Ann] -> m a) -> m a
withVarsScoped [Id]
vars (([VarDecl TyName Name DefaultUni Ann]
  -> m (PIRTerm uni fun, PIRTerm uni fun))
 -> m (PIRTerm uni fun, PIRTerm uni fun))
-> ([VarDecl TyName Name DefaultUni Ann]
    -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \[VarDecl TyName Name DefaultUni Ann]
vars' -> do
      PIRTerm uni fun
b <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
      PIRTerm uni fun
delayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni fun
b
      (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PLC.mkIterLamAbs [VarDecl TyName Name DefaultUni Ann]
vars' PIRTerm uni fun
b, [VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PLC.mkIterLamAbs [VarDecl TyName Name DefaultUni Ann]
vars' PIRTerm uni fun
delayed)
    AltCon
GHC.DEFAULT -> do
      -- ignore the body in the alt, because we've got a pre-compiled one
      let compiledBody :: PIRTerm uni fun
compiledBody = PIRTerm uni fun
defaultBody
      PIRTerm uni fun
nonDelayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt PIRTerm uni fun
compiledBody
      PIRTerm uni fun
delayed <- PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni fun
compiledBody m (PIRTerm uni fun)
-> (PIRTerm uni fun -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt
      (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PIRTerm uni fun
nonDelayed, PIRTerm uni fun
delayed)
  where
    wrapDefaultAlt :: (CompilingDefault uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun)
    wrapDefaultAlt :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
wrapDefaultAlt PIRTerm uni fun
body' = do
      -- need to consume the args
      [PLCType DefaultUni]
argTypes <- (Type -> m (PLCType DefaultUni))
-> [Type] -> m [PLCType DefaultUni]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Type -> m (PLCType DefaultUni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm [Type]
instArgTys
      [Name]
argNames <- [Int] -> (Int -> m Name) -> m [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0 .. ([PLCType DefaultUni] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PLCType DefaultUni]
argTypes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)] (\Int
i -> Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
safeFreshName (Text -> m Name) -> Text -> m Name
forall a b. (a -> b) -> a -> b
$ Text
"default_arg" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i))
      PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ [VarDecl TyName Name DefaultUni Ann]
-> PIRTerm uni fun -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
[VarDecl tyname name uni ann] -> term ann -> term ann
PIR.mkIterLamAbs ((Name -> PLCType DefaultUni -> VarDecl TyName Name DefaultUni Ann)
-> [Name]
-> [PLCType DefaultUni]
-> [VarDecl TyName Name DefaultUni Ann]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Ann
-> Name -> PLCType DefaultUni -> VarDecl TyName Name DefaultUni Ann
forall tyname name (uni :: * -> *) ann.
ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
PIR.VarDecl Ann
annMayInline) [Name]
argNames [PLCType DefaultUni]
argTypes) PIRTerm uni fun
body'

-- See Note [GHC runtime errors]
isErrorId :: GHC.Id -> Bool
isErrorId :: Id -> Bool
isErrorId Id
ghcId = Id
ghcId Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
GHC.errorIds

-- See Note [Uses of Eq]
isProbablyBytestringEq :: GHC.Id -> Bool
isProbablyBytestringEq :: Id -> Bool
isProbablyBytestringEq (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
  | Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
  , ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.ByteString.Internal" Bool -> Bool -> Bool
|| ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Data.ByteString.Lazy.Internal"
  , OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"eq" =
      Bool
True
isProbablyBytestringEq Id
_ = Bool
False

isProbablyIntegerEq :: GHC.Id -> Bool
isProbablyIntegerEq :: Id -> Bool
isProbablyIntegerEq (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
  | Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
  , ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Num.Integer"
  , OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"integerEq" =
      Bool
True
isProbablyIntegerEq Id
_ = Bool
False

-- | Check for literal ranges like [1..9] and [1, 5..101].  This will also
-- return `True` if there's an explicit use of `enumFromTo` or similar.
isProbablyBoundedRange :: GHC.Id -> Bool
isProbablyBoundedRange :: Id -> Bool
isProbablyBoundedRange (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
    | Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
    , ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Enum" =
        (String
"$fEnum" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName Bool -> Bool -> Bool
&&
         (  String
"_$cenumFromTo"     String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName  -- [1..100]
         Bool -> Bool -> Bool
|| String
"_$cenumFromThenTo" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName  -- [1,3..100]
         )
        )
        Bool -> Bool -> Bool
|| String
"enumDeltaToInteger" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName
        -- ^ These are introduced by inlining for Integer ranges in
        -- GHC.Enum. This also happens for Char, Word, and Int, but those types
        -- aren't supported in Plutus Core.
        where methodName :: String
methodName = OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n)
isProbablyBoundedRange Id
_ = Bool
False

-- | Check for literal ranges like [1..] and [1, 5..].  This will also return
-- `True` if there's an explicit use of `enumFrom` or similar.
isProbablyUnboundedRange :: GHC.Id -> Bool
isProbablyUnboundedRange :: Id -> Bool
isProbablyUnboundedRange (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Name
n)
    | Just Module
m <- Name -> Maybe Module
GHC.nameModule_maybe Name
n
    , ModuleName -> String
GHC.moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName Module
m) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"GHC.Enum" =
        (String
"$fEnum" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName Bool -> Bool -> Bool
&&
         (  String
"_$cenumFrom"     String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName  -- [1..]
         Bool -> Bool -> Bool
|| String
"_$cenumFromThen" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
methodName  -- [1,3..]
         )
        )
        Bool -> Bool -> Bool
|| String
"enumDeltaInteger" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
methodName  -- Introduced by inlining
        where methodName :: String
methodName = OccName -> String
GHC.occNameString (Name -> OccName
GHC.nameOccName Name
n)
isProbablyUnboundedRange Id
_ = Bool
False


{- Note [GHC runtime errors]
GHC has a number of runtime errors for things like pattern matching failures and so on.

We just translate these directly into calls to error, throwing away any other information.
-}

{- Note [Uses of Eq]
Eq can pop up in some annoying places:
- Literal patterns can introduce guards that use == from Eq
- Users can just plain use it instead of our Eq

This typically then leads to things we can't compile.

So, we can try and give an error when people do this. The obvious thing to do is to give an
error if we see a method of Eq. However, this doesn't work since the methods often get
inlined before we see them, either by the simplifier pass we run on our own module, or
because the simplifier does at least gentle inlining on unfoldings from other modules
before we see them.

So we have a few special cases in addition to catch things that look like inlined Integer or
ByteString equality, since those are especially likely to come up.
-}

{- Note [At patterns]
GHC handles @-patterns by adding a variable to each case expression representing the scrutinee
of the expression.

We handle this by simply let-binding that variable outside our generated case.

However, there is a subtlety: we'd like this binding to be removed by the dead-binding removal pass in PIR,
but only where we don't absolutely need it to be sure the scrutinee is evaluated. Fortunately, provided
we do a pattern match at all we will evaluate the scrutinee, since we do pattern matching by applying the scrutinee.

So the only case where we *need* to keep the binding in place is the case described in Note [Evaluation-only cases].
In this case we make a strict binding, in all others we make a non-strict binding.
-}

{- Note [Evaluation-only cases]
GHC sometimes generates case expressions where there is only a single alternative, and where none
of the variables bound by the alternative are live (see Note [Occurrence analysis] for how we tell
that this is the case).

What this amounts to is ensuring the expression is evaluated - hence one place this appears is bang
patterns.

It can do this even if the argument is a type variable (i.e. not known to be a datatype) by producing
a default-only case expression! Also, this can happen to our opaque builtin wrapper types in the
presence of e.g. bang patterns.

We can't actually compile this as a pattern match, since we need to know the actual type to do that,
(or in the case of builtin wrapper types, they're supposed to be opaque!).
But in the case where there is only one alternative with no live variables, we don't *need* to, because it
doesn't actually *do* anything with the contents of the datatype. So we can just compile this by returning
the body of the alternative wrapped in a strict let which binds the scrutinee. That achieves the
same thing as GHC wants (since GHC does expect the scrutinee to be in scope!).
-}

{- Note [Coercions and newtypes]
GHC is keen to put coercions in, they're usually great for it. However, this is a pain for us, since
you can have all kinds of fancy coercions, like coercions between functions where some of the arguments
are newtypes. We don't need to support all the stuff you can do with coercions, but we do want to
support newtypes.

A previous approach was to inspect coercions to try and work out if they were coercions between a newtype
and its underlying type, and if so manually construct/deconstruct it. This had a number of disadvantages.
- It only worked on very specific cases (e.g. if the simplifier gets loose it can make more complicated
  coercions that we can't obviously deconstruct without much more work)
- It wasn't future-proof. It's likely that GHC will move in the direction of getting rid of the structure
  of coercions (see https://gitlab.haskell.org//ghc/ghc/issues/8095#note_108189), so this approach might
  well stop working in the future.

So we would like to "believe" coercions, for at least some cases. We can
do this by always treating a newtype as it's underlying type. Except - this doesn't work for recursive
newtypes (we loop!). GHC doesn't have this problem because it treats the underlying type and the
newtype as separate types that happen to have the same representation. We don't have a separate representation
so we don't have that option.

So for the moment we:
- Treat newtypes as their underlying type.
- Blackhole newtypes when we start converting them so we can bail if they're recursive.
- Always believe coercions (i.e. just treat casts as the identity).

The final point could get us into trouble with fancier uses of coercions (since we will just accept them),
but those should fail when we typecheck the PLC. And we explicitly say we don't support such things.
-}

{- Note [Unfoldings]
GHC stores the current RHS of bindings in "unfoldings". These are used for inlining, but
also generally provide the compiler's view of the RHS of a binding. They are usually available
for other modules in the same package, and can be available cross-package if GHC decides it's
a good idea or if the binding is marked INLINABLE (or if you use `-fexpose-all-unfoldings`).

We use unfoldings to get the definitions of non-locally bound names. We then hoist these into
definitions using PIR's support for definitions. This allows a relatively direct form of code
reuse - provided that the code you are reusing has unfoldings! In practice this means you may
need to scatter some INLINABLE pragmas around, but we may be able to improve this in future,
see e.g. https://gitlab.haskell.org/ghc/ghc/issues/10871.

(Since unfoldings are updated as the compiler progresses, unfoldings for bindings in other
modules are typically fully-optimized. The exception is the unfoldings for INLINABLE bindings,
which get the *pre* optimization RHS. This is so that rewrite rules can fire. In practice, this
means that we need to be okay getting either.)
-}

{- Note [Non-strict let-bindings]
Haskell is a non-strict language, PLC is a strict language. One place that can show up is in let-bindings.
In particular, a let-binding where the RHS is not value may behave differently.
e.g.
```
let e = error in if x then e else ()
```
In Haskell this is conditionally error, in PLC it is unconditionally error.

These sorts of thing can be written by the user, or generated by GHC.

We solve this by compiling let-bindings *non-strictly*. That means we delay the body
and force all uses of it.

Conveniently, we can just use PIR's support for non-strict let bindings to implement this.
The PIR optimizer (which we use by default) will also strictify any such bindings that
turn out to be pure, so we shouldn't pay any cost for having unnecessary non-strict
bindings.
-}

{- Note [String literals]
String literals are a huge pain. Ultimately, the reason for this is that GHC's 'String' type
is transparently equal to '[Char]', it is *not* opaque.

So we can't just replace GHC's 'String' with PLC's 'String' wholesale. Otherwise things will
behave quite weirdly with things that expect 'String' to be a list. (We want to be type-preserving!)

However, we can get from GHC's 'String' to our 'String' using 'IsString'. This is fine in theory:
we can turn string literals into lists of characters, and then fold over the list adding them
into a big string. But it's bad for two reasons:
- We have to actually do the fold.
- The string literal is there in the generated code as a list of characters, which is pretty big.

So we'd really like to recognize the pattern of applying 'fromString' to a string literal, and then
just use the content of the Haskell string literal to make a PLC string literal.

This is very fiddly:
- Sometimes we get the typeclass method application.
    - But we only want to change it when it's targeting the PLC string type, so we need to have
      that type around so we can check.
- Sometimes the selector has been inlined.
    - We can't easily get access to the name of the method definition itself, so instead we mark
      that as INLINE and look for a special function ('stringToBuiltinString') that is in its
      body (and we use the OPAQUE pragma on that function to ensure it isn't inlined).
- Sometimes our heuristics fail.
    - The actual definition of 'stringToBuiltinString' works, so in the worst case we fall back
      to using it and converting the list of characters into an expression.

It's also annoying since this is the first time that we have to look for a marker function inside
the plugin compilation mode, so we have a special function that's not a builtin (in that it doesn't
just get turned into a function in PLC).
-}

{- Note [Runtime reps]
GHC has the notion of `RuntimeRep`. The kind of types is actually `TYPE rep`, where rep is of kind
`RuntimeRep`. Thus normal types have kind `TYPE LiftedRep`, and unlifted and unboxed types have
various other fancy kinds.

We don't have different runtime representations. But we can make the observation that for things
which say they should have a different runtime representation... we can just represent them as
normal lifted types. In particular, this lets us represent unboxed tuples as normal tuples, which
is helpful, since GHC will often produce these when it transforms the program.

That gives us a strategy for `RuntimeRep`
- Compile `TYPE rep` as `Type`, regardless of what `rep` is
- Ignore binders that bind types of kind `RuntimeRep`, assuming that those will only ever be used
  in a `Type rep` where we are going to ignore the rep anyway.
    - Note that binders for types of kind runtime rep binders can appear in both types and kinds!
- Ignore applications to types of kind `RuntimeRep`, since we're ignoring the binders.

Doing this thoroughly means also ignoring them in types, type constructors, and data constructors,
which is a bit more involved, see e.g.
- 'dropRuntimeRepVars' in 'compileTyCon' to ignore 'RuntimeRep' type variables
- 'dropRuntimeRepArgs' in 'compileType' and 'getMatchInstantiated'
-}

{- Note [Dependency tracking]
We use the PIR support for creating a whole bunch of definitions with dependencies between them, and then generating the code with them all
in the right order. However, this requires us to know what the dependencies of a definition *are*.

There are broadly two ways we could do this:
1. Statically determine before compiling a term/type what it depends on (e.g. by looking at the free variables in the input Core).
2. Dynamically track dependencies as we compile a term/type; whenever we see a reference to something, add it as a dependency.

We used to do the former but we now do the latter. The reason for this is that we sometimes generate bits of code
dynamically as we go. For example, the boolean coverage code *adds* some calls to 'traceBool' into the program. That means
we need a dependency on 'traceBool' - but it wasn't there at the beginning, so a static approach won't work.

The dynamic approach requires us to:
1. Track the current definition.
2. Ensure that the definition is tracked while we are recording things it may depend on (this may require creating a fake definition to begin with)
3. Record dependencies when we find them.

This typically means that we do a three-step process for a given definition:
1. Create a definition with a fake body (this is often also needed for recursion, see Note [Occurrences of recursive names])
2. Compile the real body (during which point dependencies are discovered and added to the fake definition).
3. Modify the definition with the real body.
-}

{- Note [Occurrence analysis]
GHC has "occurrence analysis", which is quite handy. In particular, it can tell you if variables are dead, which is useful
in a couple of places.

But it typically gets run *before* the simplifier, so when we get the expression we might be missing occurence analysis
for any variables that were freshly created by the simplifier. That's easy to fix: we just run the occurrence analyser
ourselves before we start.
-}

hoistExpr ::
  (CompilingDefault uni fun m ann) =>
  GHC.Var ->
  GHC.CoreExpr ->
  m (PIRTerm uni fun)
hoistExpr :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
var CoreExpr
t = do
  let name :: Name
name = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var
      lexName :: LexName
lexName = Name -> LexName
LexName Name
name
      -- If the original ID has an "always inline" pragma, then
      -- propagate that to PIR so that the PIR inliner will deal
      -- with it.
      hasInlinePragma :: Bool
hasInlinePragma = InlinePragma -> Bool
GHC.isInlinePragma (InlinePragma -> Bool) -> InlinePragma -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> InlinePragma
GHC.idInlinePragma Id
var
      ann :: Ann
ann = if Bool
hasInlinePragma then Ann
annAlwaysInline else Ann
annMayInline
  -- See Note [Dependency tracking]
  (Set LexName -> Set LexName) -> m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
(Set LexName -> Set LexName) -> m ()
modifyCurDeps (LexName -> Set LexName -> Set LexName
forall a. Ord a => a -> Set a -> Set a
Set.insert LexName
lexName)
  Maybe (PIRTerm uni fun)
maybeDef <- Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline LexName
lexName
  let addSpan :: m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
addSpan = case Id -> Maybe RealSrcSpan
getVarSourceSpan Id
var of
        Maybe RealSrcSpan
Nothing  -> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a. a -> a
id
        Just RealSrcSpan
src -> (Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Term TyName Name DefaultUni DefaultFun Ann
  -> Term TyName Name DefaultUni DefaultFun Ann)
 -> m (Term TyName Name DefaultUni DefaultFun Ann)
 -> m (Term TyName Name DefaultUni DefaultFun Ann))
-> (SrcSpan
    -> Term TyName Name DefaultUni DefaultFun Ann
    -> Term TyName Name DefaultUni DefaultFun Ann)
-> SrcSpan
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ann -> Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b.
(a -> b)
-> Term TyName Name DefaultUni DefaultFun a
-> Term TyName Name DefaultUni DefaultFun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ann -> Ann)
 -> Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun Ann)
-> (SrcSpan -> Ann -> Ann)
-> SrcSpan
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Ann -> Ann
addSrcSpan (SrcSpan
 -> m (Term TyName Name DefaultUni DefaultFun Ann)
 -> m (Term TyName Name DefaultUni DefaultFun Ann))
-> SrcSpan
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
src RealSrcSpan -> Getting SrcSpan RealSrcSpan SrcSpan -> SrcSpan
forall s a. s -> Getting a s a -> a
^. Getting SrcSpan RealSrcSpan SrcSpan
Iso' RealSrcSpan SrcSpan
srcSpanIso
  case Maybe (PIRTerm uni fun)
maybeDef of
    Just PIRTerm uni fun
term -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
term
    -- See Note [Dependency tracking]
    Maybe (PIRTerm uni fun)
Nothing -> LexName -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
Compiling uni fun m ann =>
LexName -> m a -> m a
withCurDef LexName
lexName (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
-> m (PIRTerm uni fun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
1 (SDoc
"Compiling definition of:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
var) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
      VarDecl TyName Name DefaultUni Ann
var' <- Ann -> Id -> m (VarDecl TyName Name DefaultUni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Ann -> Id -> m (PLCVar uni)
compileVarFresh Ann
ann Id
var
      -- See Note [Occurrences of recursive names]
      LexName
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> Set LexName
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key -> TermDefWithStrictness uni fun ann -> Set key -> m ()
PIR.defineTerm
        LexName
lexName
        (VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var' (Ann
-> VarDecl TyName Name DefaultUni Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
ann VarDecl TyName Name DefaultUni Ann
var', Strictness
PIR.Strict))
        Set LexName
forall a. Monoid a => a
mempty

      Term TyName Name DefaultUni DefaultFun Ann
t' <- VarDecl TyName Name DefaultUni Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs VarDecl TyName Name DefaultUni Ann
var' (Term TyName Name DefaultUni DefaultFun Ann
 -> m (Term TyName Name DefaultUni DefaultFun Ann))
-> m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (Term TyName Name DefaultUni DefaultFun Ann)
-> m (Term TyName Name DefaultUni DefaultFun Ann)
addSpan (CoreExpr -> m (Term TyName Name DefaultUni DefaultFun Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
t)
      -- See Note [Non-strict let-bindings]
      LexName
-> (TermDefWithStrictness DefaultUni DefaultFun Ann
    -> TermDefWithStrictness DefaultUni DefaultFun Ann)
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key
-> (TermDefWithStrictness uni fun ann
    -> TermDefWithStrictness uni fun ann)
-> m ()
PIR.modifyTermDef LexName
lexName (TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall a b. a -> b -> a
const (TermDefWithStrictness DefaultUni DefaultFun Ann
 -> TermDefWithStrictness DefaultUni DefaultFun Ann
 -> TermDefWithStrictness DefaultUni DefaultFun Ann)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var' (Term TyName Name DefaultUni DefaultFun Ann
t', Strictness
PIR.NonStrict))
      PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> VarDecl TyName Name DefaultUni Ann -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
ann VarDecl TyName Name DefaultUni Ann
var'

maybeProfileRhs :: (CompilingDefault uni fun m ann) => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs PLCVar uni
var PIRTerm uni fun
t = do
  CompileContext{ccOpts :: forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts = CompileOptions
compileOpts} <- m (CompileContext DefaultUni DefaultFun)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let ty :: Type TyName uni Ann
ty = PLCVar uni -> Type TyName uni Ann
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> Type tyname uni ann
PLC._varDeclType PLCVar uni
var
      varName :: Name
varName = PLCVar uni -> Name
forall tyname name (uni :: * -> *) ann.
VarDecl tyname name uni ann -> name
PLC._varDeclName PLCVar uni
var
      displayName :: Text
displayName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a str. (PrettyPlc a, Render str) => a -> str
PP.displayPlcSimple Name
varName
      isFunctionOrAbstraction :: Bool
isFunctionOrAbstraction = case Type TyName uni Ann
ty of PLC.TyFun{} -> Bool
True; PLC.TyForall{} -> Bool
True; Type TyName uni Ann
_ -> Bool
False
  -- Trace only if profiling is on *and* the thing being defined is a function
  if CompileOptions -> ProfileOpts
coProfile CompileOptions
compileOpts ProfileOpts -> ProfileOpts -> Bool
forall a. Eq a => a -> a -> Bool
== ProfileOpts
All Bool -> Bool -> Bool
&& Bool
isFunctionOrAbstraction
    then do
      Name
thunk <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
PLC.freshName Text
"thunk"
      Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term TyName Name DefaultUni DefaultFun Ann
 -> m (Term TyName Name DefaultUni DefaultFun Ann))
-> Term TyName Name DefaultUni DefaultFun Ann
-> m (Term TyName Name DefaultUni DefaultFun Ann)
forall a b. (a -> b) -> a -> b
$ Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracingInside Name
thunk Text
displayName PIRTerm uni fun
Term TyName Name DefaultUni DefaultFun Ann
t Type TyName uni Ann
PLCType DefaultUni
ty
    else PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
t

mkTrace ::
  (uni `PLC.HasTermLevel` T.Text) =>
  PLC.Type PLC.TyName uni Ann ->
  T.Text ->
  PIRTerm uni PLC.DefaultFun ->
  PIRTerm uni PLC.DefaultFun
mkTrace :: forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace Type TyName uni Ann
ty Text
str PIRTerm uni DefaultFun
v =
  PIRTerm uni DefaultFun
-> [(Ann, PIRTerm uni DefaultFun)] -> PIRTerm uni DefaultFun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PLC.mkIterApp
    (Ann
-> PIRTerm uni DefaultFun
-> Type TyName uni Ann
-> PIRTerm uni DefaultFun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (Ann -> DefaultFun -> PIRTerm uni DefaultFun
forall tyname name (uni :: * -> *) fun a.
a -> fun -> Term tyname name uni fun a
PIR.Builtin Ann
annMayInline DefaultFun
PLC.Trace) Type TyName uni Ann
ty)
    ((Ann
annMayInline,) (PIRTerm uni DefaultFun -> (Ann, PIRTerm uni DefaultFun))
-> [PIRTerm uni DefaultFun] -> [(Ann, PIRTerm uni DefaultFun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ann -> Text -> PIRTerm uni DefaultFun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline Text
str, PIRTerm uni DefaultFun
v])

-- `mkLazyTrace ty str v` builds the term `force (trace str (delay v))` if `v` has type `ty`
mkLazyTrace ::
  (CompilingDefault uni fun m ann) =>
  PLC.Type PLC.TyName uni Ann ->
  T.Text ->
  PIRTerm uni PLC.DefaultFun ->
  m (PIRTerm uni fun)
mkLazyTrace :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
mkLazyTrace Type TyName uni Ann
ty Text
str PIRTerm uni DefaultFun
v = do
  PIRTerm uni DefaultFun
delayedBody <- PIRTerm uni DefaultFun -> m (PIRTerm uni DefaultFun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
delay PIRTerm uni DefaultFun
v
  Type TyName uni Ann
delayedType <- Type TyName uni Ann -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
PIRType uni -> m (PIRType uni)
delayType Type TyName uni Ann
ty
  PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PIRTerm uni fun -> m (PIRTerm uni fun)
force (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace Type TyName uni Ann
delayedType Text
str PIRTerm uni DefaultFun
delayedBody

{- Note [Profiling polymorphic functions]
In order to profile polymorphic functions, we have to go under the type abstractions.
But we also need the type of the final inner term in order to construct the correct
invocations of 'trace'. At the moment we get this from the *type* of the term.

But this goes wrong as soon as there are type variables involved!

id :: forall a . a -> a
id = /\a . \(x :: a) -> x -- The 'a' here is not the same as the 'a' in the type signature!

The type of the term needs to use the type variables bound by the type abstractions,
not the ones bound by the foralls in the type signature.

We sort this out in a hacky way by continuing to use the type of the overall term, but
constructing a substitution from the type-bound variables to the term-bound variables,
and then applying that at the end. Not pleasant, but it works.

Note that creating a substitution with a map relies on globally unique names in types.
But that's okay, because these are all types we've been creating just now in Quote, so
we should have globally unique names
-}

{- Note [Term/type argument mismatches]
Given a term t and its type ty we can process them in parallel popping off arguments/function types.

But we can end up with a mismatch:
- We run out of arguments at the term level e.g. because we see something like `(\x -> \y -> y) 1`,
which is of function type but isn't a lambda until you reduce.
- We run out of arguments at the type level e.g. because we see something like `(\a -> (a -> a)) b`,
which is a function type but isn't a function type until you reduce.

It's usually okay to stop at this point, since the remaining things usually aren't "proper" arguments.
In the term case, it's a lambda computed by an application, which won't occur from a "proper" argument.
In the type case, we only generate type lambdas for newtypes, which will block "proper" arguments anyway,
i.e. it comes from something like this:

f :: Identity (a -> a)
f = Identity (\x -> x)
-}

{- | Add entry/exit tracing inside a term's leading arguments, both term and type arguments.
@(/\a -> \b -> body)@ into @/\a -> \b -> entryExitTracing body@.
-}
entryExitTracingInside ::
  PIR.Name ->
  T.Text ->
  PIRTerm PLC.DefaultUni PLC.DefaultFun ->
  PLCType PLC.DefaultUni ->
  PIRTerm PLC.DefaultUni PLC.DefaultFun
entryExitTracingInside :: Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracingInside Name
lamName Text
displayName = Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
forall a. Monoid a => a
mempty
  where
    go ::
      Map.Map PLC.TyName (PLCType PLC.DefaultUni) ->
      PIRTerm PLC.DefaultUni PLC.DefaultFun ->
      PLCType PLC.DefaultUni ->
      PIRTerm PLC.DefaultUni PLC.DefaultFun
    go :: Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst (LamAbs Ann
ann Name
n PLCType DefaultUni
t Term TyName Name DefaultUni DefaultFun Ann
body) (PLC.TyFun Ann
_ PLCType DefaultUni
_dom PLCType DefaultUni
cod) =
      -- when t = \x -> body, => \x -> entryExitTracingInside body
      Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
LamAbs Ann
ann Name
n PLCType DefaultUni
t (Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst Term TyName Name DefaultUni DefaultFun Ann
body PLCType DefaultUni
cod
    go Map TyName (PLCType DefaultUni)
subst (TyAbs Ann
ann TyName
tn1 Kind Ann
k Term TyName Name DefaultUni DefaultFun Ann
body) (PLC.TyForall Ann
_ TyName
tn2 Kind Ann
_k PLCType DefaultUni
ty) =
      -- when t = /\x -> body, => /\x -> entryExitTracingInside body
      -- See Note [Profiling polymorphic functions]
      let subst' :: Map TyName (PLCType DefaultUni)
subst' = TyName
-> PLCType DefaultUni
-> Map TyName (PLCType DefaultUni)
-> Map TyName (PLCType DefaultUni)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TyName
tn2 (Ann -> TyName -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
ann -> tyname -> Type tyname uni ann
PLC.TyVar Ann
annMayInline TyName
tn1) Map TyName (PLCType DefaultUni)
subst
       in Ann
-> TyName
-> Kind Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> tyname
-> Kind a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
TyAbs Ann
ann TyName
tn1 Kind Ann
k (Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$ Map TyName (PLCType DefaultUni)
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
go Map TyName (PLCType DefaultUni)
subst' Term TyName Name DefaultUni DefaultFun Ann
body PLCType DefaultUni
ty
    -- See Note [Term/type argument mismatches]
    -- Even if there still look like there are arguments on the term or the type level, because we've hit
    -- a mismatch we go ahead and insert our profiling traces here.
    go Map TyName (PLCType DefaultUni)
subst Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty =
      -- See Note [Profiling polymorphic functions]
      let ty' :: PLCType DefaultUni
ty' = (TyName -> Maybe (PLCType DefaultUni))
-> PLCType DefaultUni -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
(tyname -> Maybe (Type tyname uni ann))
-> Type tyname uni ann -> Type tyname uni ann
PLC.typeSubstTyNames (\TyName
tn -> TyName
-> Map TyName (PLCType DefaultUni) -> Maybe (PLCType DefaultUni)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TyName
tn Map TyName (PLCType DefaultUni)
subst) PLCType DefaultUni
ty
       in Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracing Name
lamName Text
displayName Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty'

-- | Add tracing before entering and after exiting a term.
entryExitTracing ::
  PLC.Name ->
  T.Text ->
  PIRTerm PLC.DefaultUni PLC.DefaultFun ->
  PLC.Type PLC.TyName PLC.DefaultUni Ann ->
  PIRTerm PLC.DefaultUni PLC.DefaultFun
entryExitTracing :: Name
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
entryExitTracing Name
lamName Text
displayName Term TyName Name DefaultUni DefaultFun Ann
e PLCType DefaultUni
ty =
  let defaultUnitTy :: Type tyname DefaultUni Ann
defaultUnitTy = Ann -> SomeTypeIn DefaultUni -> Type tyname DefaultUni Ann
forall tyname (uni :: * -> *) ann.
ann -> SomeTypeIn uni -> Type tyname uni ann
PLC.TyBuiltin Ann
annMayInline (DefaultUni (Esc ()) -> SomeTypeIn DefaultUni
forall (uni :: * -> *) k (a :: k). uni (Esc a) -> SomeTypeIn uni
PLC.SomeTypeIn DefaultUni (Esc ())
PLC.DefaultUniUnit)
      defaultUnit :: Term tyname name DefaultUni fun Ann
defaultUnit = Ann
-> Some (ValueOf DefaultUni) -> Term tyname name DefaultUni fun Ann
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (DefaultUni (Esc ()) -> () -> Some (ValueOf DefaultUni)
forall a (uni :: * -> *). uni (Esc a) -> a -> Some (ValueOf uni)
PLC.someValueOf DefaultUni (Esc ())
PLC.DefaultUniUnit ())
   in -- (trace @(() -> c) "entering f" (\() -> trace @c "exiting f" body) ())
      Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply
        Ann
annMayInline
        ( PLCType DefaultUni
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace
            (Ann
-> PLCType DefaultUni -> PLCType DefaultUni -> PLCType DefaultUni
forall tyname (uni :: * -> *) ann.
ann
-> Type tyname uni ann
-> Type tyname uni ann
-> Type tyname uni ann
PLC.TyFun Ann
annMayInline PLCType DefaultUni
forall {tyname}. Type tyname DefaultUni Ann
defaultUnitTy PLCType DefaultUni
ty) -- ()-> ty
            (Text
"entering " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
displayName)
            -- \() -> trace @c "exiting f" e
            (Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
LamAbs Ann
annMayInline Name
lamName PLCType DefaultUni
forall {tyname}. Type tyname DefaultUni Ann
defaultUnitTy (PLCType DefaultUni
-> Text
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall (uni :: * -> *).
HasTermLevel uni Text =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> PIRTerm uni DefaultFun
mkTrace PLCType DefaultUni
ty (Text
"exiting " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
displayName) Term TyName Name DefaultUni DefaultFun Ann
e))
        )
        Term TyName Name DefaultUni DefaultFun Ann
forall {tyname} {name} {fun}. Term tyname name DefaultUni fun Ann
defaultUnit

-- Expressions

{- Note [Tracking coverage and lazyness]
   When we insert a coverage annotation `a` that is meant to be collected when we execute
   `a` we would like do something like `trace (show a) body`. However, we can't do this
   because `body` may throw an exception and that would in turn cause `show a` never to be logged.
   To get around this we instead generate the code `force (trace (show a) (delay body))` to
   guarantee that the annotation `a` is logged before we execute `body`.
-}

{- Note [Boolean coverage]
   During testing it is useful (sometimes even critical) to know which boolean
   expressions have evaluated to true and false respectively. To track this we
   introduce `traceBool "<expr evaluated to True>" "<expr evaluated to False>" expr`
   around every non-constructor boolean typed expression `expr` with a known source location
   when boolean coverage is turned on.

   The annotation `<expr evaluated to True>` is implemented by adding a `CoverBool location True`
   coverage annotation with the head function in `expr` as metadata. This means that in an expression
   like:
   `foo x < bar y && all isGood xs`
   We will get annotations for `&&`, `<`, `all`, and `isGood` (given that `isGood` is defined in a module
   with coverage turned on).
-}

compileExpr ::
  (CompilingDefault uni fun m ann) =>
  GHC.CoreExpr ->
  m (PIRTerm uni fun)
compileExpr :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
e = Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
2 (SDoc
"Compiling expr:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
e) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
  -- See Note [Scopes]
  CompileContext{ccScope :: forall (uni :: * -> *) fun. CompileContext uni fun -> Scope uni
ccScope = Scope uni
scope, ccNameInfo :: forall (uni :: * -> *) fun. CompileContext uni fun -> NameInfo
ccNameInfo = NameInfo
nameInfo, ccModBreaks :: forall (uni :: * -> *) fun.
CompileContext uni fun -> Maybe ModBreaks
ccModBreaks = Maybe ModBreaks
maybeModBreaks, ccBuiltinsInfo :: forall (uni :: * -> *) fun.
CompileContext uni fun -> BuiltinsInfo uni fun
ccBuiltinsInfo = BuiltinsInfo uni fun
binfo} <- m (CompileContext uni fun)
forall r (m :: * -> *). MonadReader r m => m r
ask

  TyCon
builtinIntegerTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinInteger NameInfo
nameInfo of
    Just (GHC.ATyCon TyCon
builtinInteger) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinInteger
    Maybe TyThing
_                                -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Integer builtin"

  TyCon
builtinBoolTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinBool NameInfo
nameInfo of
    Just (GHC.ATyCon TyCon
builtinBool) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinBool
    Maybe TyThing
_                             -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Bool builtin"

  TyCon
builtinDataTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinData NameInfo
nameInfo of
    Just (GHC.ATyCon TyCon
builtinData) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinData
    Maybe TyThing
_                             -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Data builtin"

  TyCon
builtinPairTyCon <- case Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinPair NameInfo
nameInfo of
    Just (GHC.ATyCon TyCon
builtinPair) -> TyCon -> m TyCon
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyCon
builtinPair
    Maybe TyThing
_                             -> Error DefaultUni DefaultFun ann -> m TyCon
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m TyCon)
-> Error DefaultUni DefaultFun ann -> m TyCon
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for Pair builtin"

  -- TODO: Maybe share this to avoid repeated lookups. Probably cheap, though.
  (Name
stringTyName, Name
sbsName) <- case (Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinString NameInfo
nameInfo, Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup 'Builtins.stringToBuiltinString NameInfo
nameInfo) of
    (Just TyThing
t1, Just TyThing
t2) -> (Name, Name) -> m (Name, Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t1, TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t2)
    (Maybe TyThing, Maybe TyThing)
_                  -> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (Name, Name))
-> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for String builtin"

  (Name
bsTyName, Name
sbbsName) <- case (Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ''Builtins.BuiltinByteString NameInfo
nameInfo, Name -> NameInfo -> Maybe TyThing
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup 'Builtins.stringToBuiltinByteString NameInfo
nameInfo) of
    (Just TyThing
t1, Just TyThing
t2) -> (Name, Name) -> m (Name, Name)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t1, TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
t2)
    (Maybe TyThing, Maybe TyThing)
_                  -> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (Name, Name))
-> Error DefaultUni DefaultFun ann -> m (Name, Name)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"No info for ByteString builtin"

  Name
useToOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.useToOpaque
  Name
useFromOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.useFromOpaque
  Name
mkNilOpaqueName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'Builtins.mkNilOpaque
  Name
boolOperatorOr <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing '(PlutusTx.Bool.||)
  Name
boolOperatorAnd <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing '(PlutusTx.Bool.&&)
  case CoreExpr
e of
    {- Note [Lazy boolean operators]
      (||) and (&&) have a special treatment: we want them lazy in the second argument,
      as this is the behavior in Haskell and other PLs.
      Covered by this spec: plutus-tx-plugin/test/ShortCircuit/Spec.hs
    -}
    -- Lazy ||
    GHC.App (GHC.App (GHC.Var Id
var) CoreExpr
a) CoreExpr
b | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
boolOperatorOr ->
      CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
GHC.mkIfThenElse CoreExpr
a (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
GHC.trueDataConId) CoreExpr
b
    -- Lazy &&
    GHC.App (GHC.App (GHC.Var Id
var) CoreExpr
a) CoreExpr
b | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
var Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
boolOperatorAnd ->
      CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
GHC.mkIfThenElse CoreExpr
a CoreExpr
b (Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
GHC.falseDataConId)

    -- See Note [String literals]
    -- IsString has only one method, so it's enough to know that it's an IsString method
    -- to know we're looking at fromString.
    -- We can safely commit to this match as soon as we've seen fromString - we won't accept
    -- any applications of fromString that aren't creating literals of our builtin types.
    (CoreExpr -> CoreExpr
strip -> GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.ClassOpId Class
cls)) `GHC.App` GHC.Type Type
ty `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
content
      | Class -> Name
forall a. NamedThing a => a -> Name
GHC.getName Class
cls Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.isStringClassName ->
          case Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe Type
ty of
            Just TyCon
tc -> case CoreExpr -> Maybe ByteString
stringExprContent (CoreExpr -> CoreExpr
strip CoreExpr
content) of
              Just ByteString
bs ->
                if
                    | TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
bsTyName -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ ByteString -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue ByteString
bs
                    | TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyCon
tc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
stringTyName -> case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs of
                        Right Text
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Text -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue Text
t
                        Left UnicodeException
err ->
                          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> (Text -> Error DefaultUni DefaultFun ann)
-> Text
-> m (PIRTerm uni fun)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (Text -> m (PIRTerm uni fun)) -> Text -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                            Text
"Text literal with invalid UTF-8 content: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
                    | Bool
otherwise ->
                        (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                          SDoc
"Use of fromString on type other than builtin strings or bytestrings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
ty
              Maybe ByteString
Nothing ->
                (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                  SDoc
"Use of fromString with inscrutable content:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr CoreExpr
content
            Maybe TyCon
Nothing ->
              (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                SDoc
"Use of fromString on type other than builtin strings or bytestrings:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
ty
    -- 'stringToBuiltinByteString' invocation
    (CoreExpr -> CoreExpr
strip -> GHC.Var Id
n) `GHC.App` (CoreExpr -> CoreExpr
strip -> CoreExpr -> Maybe ByteString
stringExprContent -> Just ByteString
bs)
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sbbsName ->
          PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ ByteString -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue ByteString
bs
    -- 'stringToBuiltinString' invocation
    (CoreExpr -> CoreExpr
strip -> GHC.Var Id
n) `GHC.App` (CoreExpr -> CoreExpr
strip -> CoreExpr -> Maybe ByteString
stringExprContent -> Just ByteString
bs) | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
sbsName ->
      case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs of
        Right Text
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> Some (ValueOf uni) -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> Some (ValueOf uni) -> Term tyname name uni fun a
PIR.Constant Ann
annMayInline (Some (ValueOf uni) -> PIRTerm uni fun)
-> Some (ValueOf uni) -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ Text -> Some (ValueOf uni)
forall a (uni :: * -> *). Contains uni a => a -> Some (ValueOf uni)
PLC.someValue Text
t
        Left UnicodeException
err ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
            Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$
              Text
"Text literal with invalid UTF-8 content: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
err)
    -- See Note [Literals]
    GHC.Lit Literal
lit -> Literal -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Literal -> m (PIRTerm uni fun)
compileLiteral Literal
lit
    -- These are all wrappers around string and char literals, but keeping them allows us to give better errors
    -- unpackCString# is just a wrapper around a literal
    GHC.Var Id
n `GHC.App` CoreExpr
expr | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
expr
    -- See Note [unpackFoldrCString#]
    GHC.Var Id
build `GHC.App` CoreExpr
_ `GHC.App` GHC.Lam Id
_ (GHC.Var Id
unpack `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
expr)
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
build Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.buildName Bool -> Bool -> Bool
&& Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
unpack Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.unpackCStringFoldrName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
expr
    -- C# is just a wrapper around a literal
    GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) `GHC.App` CoreExpr
arg | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
GHC.charDataCon -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
    -- Handle constructors of 'Integer'
    GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) `GHC.App` CoreExpr
arg | DataCon -> TyCon
GHC.dataConTyCon DataCon
dc TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
GHC.integerTyCon -> do
      PIRTerm uni fun
i <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
      -- IN is a negative integer!
      if DataCon -> Name
GHC.dataConName DataCon
dc Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.integerINDataConName
        then do
          PIRTerm uni fun
negateTerm <- m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
lookupIntegerNegate
          PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp PIRTerm uni fun
negateTerm [(Ann
annMayInline, PIRTerm uni fun
i)]
        else PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
i
    -- Unboxed unit, (##).
    GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) | DataCon
dc DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
GHC.unboxedUnitDataCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ann -> () -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PIR.mkConstant Ann
annMayInline ())
    -- Ignore the magic 'noinline' function, it's the identity but has no unfolding.
    -- See Note [GHC.Magic.noinline]
    GHC.Var Id
n `GHC.App` GHC.Type Type
_ `GHC.App` CoreExpr
arg | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.noinlineIdName -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
    -- See Note [GHC runtime errors]
    -- <error func> <runtime rep> <overall type> <call stack> <message>
    GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` CoreExpr
_ `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ `GHC.App` CoreExpr
_ ->
      Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
    -- <error func> <runtime rep> <overall type> <message>
    GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` CoreExpr
_ `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ ->
      Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
    -- <error func> <overall type> <message>
    GHC.Var (Id -> Bool
isErrorId -> Bool
True) `GHC.App` GHC.Type Type
t `GHC.App` CoreExpr
_ ->
      Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
errorFunc m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
    GHC.Var Id
n `GHC.App` GHC.Type Type
ty
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
mkNilOpaqueName -> case Type
ty of
          GHC.TyConApp TyCon
tyCon []
            | TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
GHC.integerTyCon Bool -> Bool -> Bool
|| TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinIntegerTyCon ->
                PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Integer] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @Integer)
            | TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinBoolTyCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Bool] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @Bool)
            | TyCon
tyCon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
builtinDataTyCon -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [Data] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @PLC.Data)
          GHC.TyConApp TyCon
tyCon [GHC.TyConApp TyCon
tyArg1 [], GHC.TyConApp TyCon
tyArg2 []]
            | (TyCon
tyCon, TyCon
tyArg1, TyCon
tyArg2) (TyCon, TyCon, TyCon) -> (TyCon, TyCon, TyCon) -> Bool
forall a. Eq a => a -> a -> Bool
== (TyCon
builtinPairTyCon, TyCon
builtinDataTyCon, TyCon
builtinDataTyCon) ->
                PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> [(Data, Data)] -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline ([] @(PLC.Data, PLC.Data))
          Type
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"'mkNil' applied to an unknown type"
    GHC.Var Id
n
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
useToOpaqueName ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"It is no longer possible to use 'toBuiltin' with a script, use 'toOpaque' instead"
    GHC.Var Id
n
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
useFromOpaqueName ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"It is no longer possible to use 'fromBuiltin' with a script, use 'fromOpaque' instead"
    -- See Note [Uses of Eq]
    GHC.Var Id
n
      | Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
GHC.eqName ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of == from the Haskell Eq typeclass"
    GHC.Var Id
n
      | Id -> Bool
isProbablyIntegerEq Id
n ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of Haskell Integer equality, possibly via the Haskell Eq typeclass"
    GHC.Var Id
n
      | Id -> Bool
isProbablyBytestringEq Id
n ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass"
    GHC.Var Id
n
      -- Try to produce a sensible error message if a range like [1..9] is encountered.  This works
      -- by looking for occurrences of GHC.Enum.enumFromTo and similar functions; the same error
      -- occurs if these functions are used explicitly.
      | Id -> Bool
isProbablyBoundedRange Id
n ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Use of enumFromTo or enumFromThenTo, possibly via range syntax. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                  String
"Please use PlutusTx.Enum.enumFromTo or PlutusTx.Enum.enumFromThenTo instead.")
    -- Throw an error if we find an infinite range like [1..]
    GHC.Var Id
n
      | Id -> Bool
isProbablyUnboundedRange Id
n ->
          Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (Text -> Error DefaultUni DefaultFun ann)
-> Text -> Error DefaultUni DefaultFun ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String
"Use of enumFrom or enumFromThen, possibly via range syntax. " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                                  String
"Unbounded ranges are not supported.")
    -- locally bound vars
    GHC.Var (Scope uni -> Name -> Maybe (PLCVar uni)
forall (uni :: * -> *). Scope uni -> Name -> Maybe (PLCVar uni)
lookupName Scope uni
scope (Name -> Maybe (PLCVar uni))
-> (Id -> Name) -> Id -> Maybe (PLCVar uni)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName -> Just PLCVar uni
var) -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann -> PLCVar uni -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
ann -> VarDecl tyname name uni ann -> term ann
PIR.mkVar Ann
annMayInline PLCVar uni
var
    -- Special kinds of id
    GHC.Var (Id -> IdDetails
GHC.idDetails -> GHC.DataConWorkId DataCon
dc) -> DataCon -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
DataCon -> m (PIRTerm uni fun)
compileDataConRef DataCon
dc
    -- Class ops don't have unfoldings in general (although they do if they're for one-method classes, so we
    -- want to check the unfoldings case first), see GHC:Note [ClassOp/DFun selection] for why. That
    -- means we have to reconstruct the RHS ourselves, though, which is a pain.
    GHC.Var n :: Id
n@(Id -> IdDetails
GHC.idDetails -> GHC.ClassOpId Class
cls) -> do
      -- This code (mostly) lifted from MkId.mkDictSelId, which makes unfoldings for those dictionary
      -- selectors that do have them
      let sel_names :: [Name]
sel_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName (Class -> [Id]
GHC.classAllSelIds Class
cls)
      Int
val_index <- case Name -> [Name] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex (Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n) [Name]
sel_names of
        Just Int
i  -> Int -> m Int
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
        Maybe Int
Nothing -> (Text -> Error DefaultUni DefaultFun ann) -> SDoc -> m Int
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m Int) -> SDoc -> m Int
forall a b. (a -> b) -> a -> b
$ SDoc
"Id not in class method list:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
n
      let rhs :: CoreExpr
rhs = Class -> Int -> CoreExpr
GHC.mkDictSelRhs Class
cls Int
val_index

      Id -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
n CoreExpr
rhs
    GHC.Var Id
n -> do
      -- Defined names, including builtin names
      let lexName :: LexName
lexName = Name -> LexName
LexName (Name -> LexName) -> Name -> LexName
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName Id
n
      (Set LexName -> Set LexName) -> m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
(Set LexName -> Set LexName) -> m ()
modifyCurDeps (\Set LexName
d -> LexName -> Set LexName -> Set LexName
forall a. Ord a => a -> Set a -> Set a
Set.insert LexName
lexName Set LexName
d)
      Maybe (PIRTerm uni fun)
maybeDef <- Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline LexName
lexName
      case Maybe (PIRTerm uni fun)
maybeDef of
        Just PIRTerm uni fun
term -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
term
        Maybe (PIRTerm uni fun)
Nothing ->
          -- No other cases apply; compile the unfolding of the var
          case Unfolding -> Maybe CoreExpr
GHC.maybeUnfoldingTemplate (Id -> Unfolding
GHC.realIdUnfolding Id
n) of
            -- See Note [Unfoldings]
            -- The "unfolding template" includes things with normal unfoldings and also dictionary functions
            Just CoreExpr
unfolding -> Id -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> CoreExpr -> m (PIRTerm uni fun)
hoistExpr Id
n CoreExpr
unfolding
            Maybe CoreExpr
Nothing ->
              (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
FreeVariableError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                SDoc
"Variable"
                  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Id
n
                  SDoc -> SDoc -> SDoc
GHC.$+$ (IdDetails -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr (IdDetails -> SDoc) -> IdDetails -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> IdDetails
GHC.idDetails Id
n)
                  SDoc -> SDoc -> SDoc
GHC.$+$ (Unfolding -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr (Unfolding -> SDoc) -> Unfolding -> SDoc
forall a b. (a -> b) -> a -> b
$ Id -> Unfolding
GHC.realIdUnfolding Id
n)

    -- arg can be a type here, in which case it's a type instantiation
    CoreExpr
l `GHC.App` GHC.Type Type
t ->
      -- Ignore applications to types of 'RuntimeRep' kind, see Note [Runtime reps]
      if Type -> Bool
GHC.isRuntimeRepKindedTy Type
t
      then CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l
      else Ann -> PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline (PIRTerm uni fun -> Type TyName uni Ann -> PIRTerm uni fun)
-> m (PIRTerm uni fun)
-> m (Type TyName uni Ann -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l m (Type TyName uni Ann -> PIRTerm uni fun)
-> m (Type TyName uni Ann) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> m (Type TyName uni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
    -- otherwise it's a normal application
    CoreExpr
l `GHC.App` CoreExpr
arg -> Ann -> PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply Ann
annMayInline (PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun -> PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
l m (PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
arg
    -- if we're biding a type variable it's a type abstraction
    GHC.Lam b :: Id
b@(Id -> Bool
GHC.isTyVar -> Bool
True) CoreExpr
body ->
      -- Ignore type binders for runtime rep variables, see Note [Runtime reps]
      if Type -> Bool
GHC.isRuntimeRepTy (Type -> Bool) -> Type -> Bool
forall a b. (a -> b) -> a -> b
$ Id -> Type
GHC.varType Id
b
      then CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
      else Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
mkTyAbsScoped Id
b (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
    -- otherwise it's a normal lambda
    GHC.Lam Id
b CoreExpr
body -> Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Id -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
mkLamAbsScoped Id
b (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
    GHC.Let (GHC.NonRec Id
b CoreExpr
rhs) CoreExpr
body -> do
      -- the binding is in scope for the body, but not for the arg
      PIRTerm DefaultUni fun
rhs' <- CoreExpr -> m (PIRTerm DefaultUni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
rhs
      PLCType DefaultUni
ty <- case CoreExpr
rhs of
        GHC.Lit (GHC.LitNumber{}) | Type -> Type -> Bool
GHC.eqType (Id -> Type
GHC.varType Id
b) Type
GHC.byteArrayPrimTy ->
          -- Handle the following case:
          --
          -- ```PlutusTx
          -- let !x = 12345678901234567890
          -- in PlutusTx.equalsInteger x y
          -- ```
          --
          -- ```GHC Core
          -- let {
          --   x_sfhW :: ByteArray#
          --   x_sfhW = 12345678901234567890 } in
          -- equalsInteger (IP x_sfhW) y_X0
          -- ```
          --
          -- What we do here is ignoring the `ByteArray#`, and pretending that
          --`12345678901234567890` is an Integer.
          PLCType DefaultUni -> m (PLCType DefaultUni)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PLCType DefaultUni -> m (PLCType DefaultUni))
-> PLCType DefaultUni -> m (PLCType DefaultUni)
forall a b. (a -> b) -> a -> b
$ forall a (x :: a) (uni :: * -> *) ann tyname.
HasTypeLevel uni x =>
ann -> Type tyname uni ann
PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni Ann
annMayInline
        CoreExpr
_ -> Type -> m (PLCType DefaultUni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm (Type -> m (PLCType DefaultUni)) -> Type -> m (PLCType DefaultUni)
forall a b. (a -> b) -> a -> b
$ Id -> Type
GHC.varType Id
b
      -- See Note [Non-strict let-bindings]
      Id
-> PLCType DefaultUni
-> (VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> PIRType uni -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarTyScoped Id
b PLCType DefaultUni
ty ((VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
 -> m (PIRTerm uni fun))
-> (VarDecl TyName Name DefaultUni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name DefaultUni Ann
v -> do
        PIRTerm DefaultUni fun
rhs'' <- VarDecl TyName Name DefaultUni Ann
-> PIRTerm DefaultUni fun -> m (PIRTerm DefaultUni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs VarDecl TyName Name DefaultUni Ann
v PIRTerm DefaultUni fun
rhs'
        let binds :: NonEmpty (Binding TyName Name DefaultUni fun Ann)
binds = Binding TyName Name DefaultUni fun Ann
-> NonEmpty (Binding TyName Name DefaultUni fun Ann)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding TyName Name DefaultUni fun Ann
 -> NonEmpty (Binding TyName Name DefaultUni fun Ann))
-> Binding TyName Name DefaultUni fun Ann
-> NonEmpty (Binding TyName Name DefaultUni fun Ann)
forall a b. (a -> b) -> a -> b
$ Ann
-> Strictness
-> VarDecl TyName Name DefaultUni Ann
-> PIRTerm DefaultUni fun
-> Binding TyName Name DefaultUni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict VarDecl TyName Name DefaultUni Ann
v PIRTerm DefaultUni fun
rhs''
        PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
        PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> NonEmpty (Binding TyName Name uni fun Ann)
-> PIRTerm uni fun
-> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Recursivity
-> NonEmpty (Binding tyname name uni fun a)
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Let Ann
annMayInline Recursivity
PIR.NonRec NonEmpty (Binding TyName Name uni fun Ann)
NonEmpty (Binding TyName Name DefaultUni fun Ann)
binds PIRTerm uni fun
body'
    GHC.Let (GHC.Rec [(Id, CoreExpr)]
bs) CoreExpr
body ->
      [Id]
-> ([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
[Id] -> ([VarDecl TyName Name uni Ann] -> m a) -> m a
withVarsScoped (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
bs) (([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun))
-> ([PLCVar uni] -> m (PIRTerm uni fun)) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \[PLCVar uni]
vars -> do
        -- the bindings are scope in both the body and the args
        -- TODO: this is a bit inelegant matching the vars back up
        [Binding TyName Name uni fun Ann]
binds <- [(PLCVar uni, (Id, CoreExpr))]
-> ((PLCVar uni, (Id, CoreExpr))
    -> m (Binding TyName Name uni fun Ann))
-> m [Binding TyName Name uni fun Ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for ([PLCVar uni] -> [(Id, CoreExpr)] -> [(PLCVar uni, (Id, CoreExpr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [PLCVar uni]
vars [(Id, CoreExpr)]
bs) (((PLCVar uni, (Id, CoreExpr))
  -> m (Binding TyName Name uni fun Ann))
 -> m [Binding TyName Name uni fun Ann])
-> ((PLCVar uni, (Id, CoreExpr))
    -> m (Binding TyName Name uni fun Ann))
-> m [Binding TyName Name uni fun Ann]
forall a b. (a -> b) -> a -> b
$ \(PLCVar uni
v, (Id
_, CoreExpr
rhs)) -> do
          PIRTerm uni fun
rhs' <- PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeProfileRhs PLCVar uni
v (PIRTerm uni fun -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
rhs
          -- See Note [Non-strict let-bindings]
          Binding TyName Name uni fun Ann
-> m (Binding TyName Name uni fun Ann)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Binding TyName Name uni fun Ann
 -> m (Binding TyName Name uni fun Ann))
-> Binding TyName Name uni fun Ann
-> m (Binding TyName Name uni fun Ann)
forall a b. (a -> b) -> a -> b
$ Ann
-> Strictness
-> PLCVar uni
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict PLCVar uni
v PIRTerm uni fun
rhs'
        PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
        PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.Rec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
body'

    GHC.Case CoreExpr
scrutinee Id
b Type
t [CoreAlt]
alts ->
      (Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase (Bool -> CoreExpr -> Bool
forall a b. a -> b -> a
const (Bool -> CoreExpr -> Bool)
-> (Id -> Bool) -> Id -> CoreExpr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccInfo -> Bool
GHC.isDeadOcc (OccInfo -> Bool) -> (Id -> OccInfo) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IdInfo -> OccInfo
GHC.occInfo (IdInfo -> OccInfo) -> (Id -> IdInfo) -> Id -> OccInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (() :: Constraint) => Id -> IdInfo
Id -> IdInfo
GHC.idInfo) Bool
True BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
b Type
t [CoreAlt]
alts

    -- we can use source notes to get a better context for the inner expression
    -- these are put in when you compile with -g
    -- See Note [What source locations to cover]
    GHC.Tick CoreTickish
tick CoreExpr
body | Just RealSrcSpan
src <- Maybe ModBreaks -> CoreTickish -> Maybe RealSrcSpan
forall {pass :: TickishPass}.
Maybe ModBreaks -> GenTickish pass -> Maybe RealSrcSpan
getSourceSpan Maybe ModBreaks
maybeModBreaks CoreTickish
tick ->
      Int -> SDoc -> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) e a.
(MonadReader (CompileContext uni fun) m, MonadState CompileState m,
 MonadError (WithContext Text e) m) =>
Int -> SDoc -> m a -> m a
traceCompilation Int
1 (SDoc
"Compiling expr at:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> RealSrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr RealSrcSpan
src) (m (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ do
        CompileContext{ccOpts :: forall (uni :: * -> *) fun.
CompileContext uni fun -> CompileOptions
ccOpts = CompileOptions
coverageOpts} <- m (CompileContext DefaultUni DefaultFun)
forall r (m :: * -> *). MonadReader r m => m r
ask
        -- See Note [Coverage annotations]
        let anns :: [CoverageType]
anns = Set CoverageType -> [CoverageType]
forall a. Set a -> [a]
Set.toList (Set CoverageType -> [CoverageType])
-> Set CoverageType -> [CoverageType]
forall a b. (a -> b) -> a -> b
$ CompileOptions -> Set CoverageType
activeCoverageTypes CompileOptions
coverageOpts
        PIRTerm uni fun
compiledBody <- (Ann -> Ann) -> PIRTerm uni fun -> PIRTerm uni fun
forall a b.
(a -> b)
-> Term TyName Name uni fun a -> Term TyName Name uni fun b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SrcSpan -> Ann -> Ann
addSrcSpan (SrcSpan -> Ann -> Ann) -> SrcSpan -> Ann -> Ann
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
src RealSrcSpan -> Getting SrcSpan RealSrcSpan SrcSpan -> SrcSpan
forall s a. s -> Getting a s a -> a
^. Getting SrcSpan RealSrcSpan SrcSpan
Iso' RealSrcSpan SrcSpan
srcSpanIso) (PIRTerm uni fun -> PIRTerm uni fun)
-> m (PIRTerm uni fun) -> m (PIRTerm uni fun)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
        (PIRTerm uni fun -> CoverageType -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> [CoverageType] -> m (PIRTerm uni fun)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
coverageCompile CoreExpr
body ((() :: Constraint) => CoreExpr -> Type
CoreExpr -> Type
GHC.exprType CoreExpr
body) RealSrcSpan
src) PIRTerm uni fun
compiledBody [CoverageType]
anns

    -- ignore other annotations
    GHC.Tick CoreTickish
_ CoreExpr
body -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
    -- See Note [Coercions and newtypes]
    GHC.Cast CoreExpr
body CoercionR
_ -> CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
    GHC.Type Type
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Types as standalone expressions"
    GHC.Coercion CoercionR
_ -> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun))
-> Error DefaultUni DefaultFun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError Text
"Coercions as expressions"

compileCase ::
  (CompilingDefault uni fun m ann) =>
  -- | Whether the variable is dead in the expr
  (GHC.Var -> GHC.CoreExpr -> Bool) ->
  -- | Whether we should try to rewrite unnecessary constructor applications
  Bool ->
  BuiltinsInfo uni fun ->
  GHC.CoreExpr ->
  GHC.Var ->
  GHC.Type ->
  [GHC.CoreAlt] ->
  m (PIRTerm uni fun)
compileCase :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase Id -> CoreExpr -> Bool
isDead Bool
rewriteConApps BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
binder Type
t [CoreAlt]
alts = case [CoreAlt]
alts of
  [GHC.Alt AltCon
con [Id]
bs CoreExpr
body]
    -- See Note [Evaluation-only cases]
    | (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Id -> CoreExpr -> Bool
`isDead` CoreExpr
body) [Id]
bs -> do
      -- See Note [At patterns]
      PIRTerm uni fun
scrutinee' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
scrutinee
      Id
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarScoped Id
binder ((VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
 -> m (PIRTerm uni fun))
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name uni Ann
v -> do
        PIRTerm uni fun
body' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
body
        -- See Note [At patterns]
        let binds :: [Binding TyName Name uni fun Ann]
binds = [Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.Strict VarDecl TyName Name uni Ann
v PIRTerm uni fun
scrutinee']
        PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.NonRec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
body'
    | Bool
rewriteConApps
    , GHC.DataAlt DataCon
dataCon <- AltCon
con -> do
        -- Attempt to rewrite constructor applications, since sometimes they cannot be
        -- compiled (e.g., opaque constructors).
        -- For example, this rewrites

        -- ```
        -- case scrut of b {BuiltinList xs} -> ...BuiltinList @BuiltinData xs...
        -- ```
        --
        -- into
        --
        -- ```
        -- case scrut of b {BuiltinList xs} -> ...b...
        -- ```
        --
        -- after which `xs` is hopefully dead, and we can then compile it using the
        -- `all (`isDead` body) bs` branch of `compileCase`.
        let f :: CoreExpr -> CoreExpr
f (CoreExpr -> (CoreExpr, [CoreExpr])
forall b. Expr b -> (Expr b, [Expr b])
GHC.collectArgs -> (GHC.Var (Id -> Maybe DataCon
GHC.isDataConId_maybe -> Just DataCon
dataCon'), [CoreExpr]
args0))
              | DataCon
dataCon DataCon -> DataCon -> Bool
forall a. Eq a => a -> a -> Bool
== DataCon
dataCon'
              -- Discard type arguments
              , let args :: [Id]
args = (CoreExpr -> Maybe Id) -> [CoreExpr] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\case GHC.Var Id
v -> Id -> Maybe Id
forall a. a -> Maybe a
Just Id
v; CoreExpr
_ -> Maybe Id
forall a. Maybe a
Nothing) [CoreExpr]
args0
              , [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args
              , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ((Id -> Id -> Bool) -> [Id] -> [Id] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
(==) [Id]
bs [Id]
args) =
                Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
binder
            f CoreExpr
other = CoreExpr
other
            -- This time we can no longer use `GHC.isDeadOcc`. Instead we check manually.
            isDead' :: a -> a -> Bool
isDead' a
b = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b) ([a] -> Bool) -> (a -> [a]) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall from to. Biplate from to => from -> [to]
universeBi
        -- If some binders are still alive, we have to give up (rather than trying to rewrite
        -- constructor applications again, which will loop), hence `False`.
        (Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
(Id -> CoreExpr -> Bool)
-> Bool
-> BuiltinsInfo uni fun
-> CoreExpr
-> Id
-> Type
-> [CoreAlt]
-> m (PIRTerm uni fun)
compileCase Id -> CoreExpr -> Bool
forall {a} {a}. (Eq a, Data a, Data a) => a -> a -> Bool
isDead' Bool
False BuiltinsInfo uni fun
binfo CoreExpr
scrutinee Id
binder Type
t [AltCon -> [Id] -> CoreExpr -> CoreAlt
forall b. AltCon -> [b] -> Expr b -> Alt b
GHC.Alt AltCon
con [Id]
bs ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall on. Uniplate on => (on -> on) -> on -> on
transform CoreExpr -> CoreExpr
f CoreExpr
body)]
  [CoreAlt]
_ -> do
      -- See Note [At patterns]
      PIRTerm uni fun
scrutinee' <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
scrutinee
      let scrutineeType :: Type
scrutineeType = Id -> Type
GHC.varType Id
binder

      -- the variable for the scrutinee is bound inside the cases, but not in the scrutinee expression itself
      Id
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann a.
CompilingDefault uni fun m ann =>
Id -> (VarDecl TyName Name uni Ann -> m a) -> m a
withVarScoped Id
binder ((VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
 -> m (PIRTerm uni fun))
-> (VarDecl TyName Name uni Ann -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ \VarDecl TyName Name uni Ann
v -> do
        (TyCon
tc, [Type]
argTys) <- case (() :: Constraint) => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
GHC.splitTyConApp_maybe Type
scrutineeType of
          Just (TyCon
tc, [Type]
argTys) -> (TyCon, [Type]) -> m (TyCon, [Type])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TyCon
tc, [Type]
argTys)
          Maybe (TyCon, [Type])
Nothing ->
            (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (TyCon, [Type])
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
UnsupportedError (SDoc -> m (TyCon, [Type])) -> SDoc -> m (TyCon, [Type])
forall a b. (a -> b) -> a -> b
$
              SDoc
"Cannot case on a value of type:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr Type
scrutineeType
        [DataCon]
dcs <- TyCon -> m [DataCon]
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
TyCon -> m [DataCon]
getDataCons TyCon
tc

        -- it's important to instantiate the match before alts compilation
        PIRTerm uni fun
match <- Type -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRTerm uni fun)
getMatchInstantiated Type
scrutineeType
        let matched :: PIRTerm uni fun
matched = Ann -> PIRTerm uni fun -> PIRTerm uni fun -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.Apply Ann
annMayInline PIRTerm uni fun
match PIRTerm uni fun
scrutinee'

        let ([CoreAlt]
rest, Maybe CoreExpr
mdef) = [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
forall b. [Alt b] -> ([Alt b], Maybe (Expr b))
GHC.findDefault [CoreAlt]
alts
        -- This does two things:
        -- 1. Ensure that every set of alternatives has a DEFAULT alt (See Note [We always need DEFAULT])
        -- 2. Compile the body of the DEFAULT alt ahead of time so it can be shared (See Note [Sharing DEFAULT bodies])
        ([CoreAlt]
alts', PIRTerm uni fun
defCompiled) <- case Maybe CoreExpr
mdef of
          Just CoreExpr
d -> do
            PIRTerm uni fun
defCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
d
            ([CoreAlt], PIRTerm uni fun) -> m ([CoreAlt], PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreAlt] -> Maybe CoreExpr -> [CoreAlt]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
GHC.addDefault [CoreAlt]
rest (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
d), PIRTerm uni fun
defCompiled)
          Maybe CoreExpr
Nothing -> do
#if MIN_VERSION_ghc(9,6,0)
            let d :: CoreExpr
d = Type -> String -> CoreExpr
GHC.mkImpossibleExpr Type
t String
"unreachable alternative"
#else
            let d = GHC.mkImpossibleExpr t
#endif
            PIRTerm uni fun
defCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
d
            ([CoreAlt], PIRTerm uni fun) -> m ([CoreAlt], PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([CoreAlt] -> Maybe CoreExpr -> [CoreAlt]
forall b. [Alt b] -> Maybe (Expr b) -> [Alt b]
GHC.addDefault [CoreAlt]
alts (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
d), PIRTerm uni fun
defCompiled)
        Name
defName <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
PLC.freshName Text
"defaultBody"

        -- See Note [Case expressions and laziness]
        [(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts <- [DataCon]
-> (DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m [(PIRTerm uni fun, PIRTerm uni fun)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [DataCon]
dcs ((DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
 -> m [(PIRTerm uni fun, PIRTerm uni fun)])
-> (DataCon -> m (PIRTerm uni fun, PIRTerm uni fun))
-> m [(PIRTerm uni fun, PIRTerm uni fun)]
forall a b. (a -> b) -> a -> b
$ \DataCon
dc -> do
          let alt :: Maybe CoreAlt
alt = AltCon -> [CoreAlt] -> Maybe CoreAlt
forall b. AltCon -> [Alt b] -> Maybe (Alt b)
GHC.findAlt (DataCon -> AltCon
GHC.DataAlt DataCon
dc) [CoreAlt]
alts'
              -- these are the instantiated type arguments, e.g. for the data constructor Just when
              -- matching on Maybe Int it is [Int] (crucially, not [a])
              instArgTys :: [Type]
instArgTys = Scaled Type -> Type
forall a. Scaled a -> a
GHC.scaledThing (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DataCon -> [Type] -> [Scaled Type]
GHC.dataConInstOrigArgTys DataCon
dc [Type]
argTys
          case Maybe CoreAlt
alt of
            Just CoreAlt
a -> do
              -- pass in the body to use for default alternatives, see Note [Sharing DEFAULT bodies]
              (PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt) <- CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreAlt
-> [Type]
-> PIRTerm uni fun
-> m (PIRTerm uni fun, PIRTerm uni fun)
compileAlt CoreAlt
a [Type]
instArgTys (Ann -> Name -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a -> name -> Term tyname name uni fun a
PIR.Var Ann
annMayInline Name
defName)
              (PIRTerm uni fun, PIRTerm uni fun)
-> m (PIRTerm uni fun, PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt)
            Maybe CoreAlt
Nothing -> (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun, PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun, PIRTerm uni fun))
-> SDoc -> m (PIRTerm uni fun, PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ SDoc
"No alternative for:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr DataCon
dc
        let
          isPureAlt :: [Bool]
isPureAlt = [(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts [(PIRTerm uni fun, PIRTerm uni fun)]
-> ((PIRTerm uni fun, PIRTerm uni fun) -> Bool) -> [Bool]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PIRTerm uni fun
nonDelayed, PIRTerm uni fun
_) -> BuiltinsInfo uni fun
-> VarsInfo TyName Name uni Ann -> PIRTerm uni fun -> Bool
forall (uni :: * -> *) fun name tyname a.
(ToBuiltinMeaning uni fun, HasUnique name TermUnique) =>
BuiltinsInfo uni fun
-> VarsInfo tyname name uni a -> Term tyname name uni fun a -> Bool
PIR.isPure BuiltinsInfo uni fun
binfo VarsInfo TyName Name uni Ann
forall a. Monoid a => a
mempty PIRTerm uni fun
nonDelayed
          lazyCase :: Bool
lazyCase = Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
isPureAlt Bool -> Bool -> Bool
|| [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
          branches :: [PIRTerm uni fun]
branches =
            [(PIRTerm uni fun, PIRTerm uni fun)]
compiledAlts [(PIRTerm uni fun, PIRTerm uni fun)]
-> ((PIRTerm uni fun, PIRTerm uni fun) -> PIRTerm uni fun)
-> [PIRTerm uni fun]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(PIRTerm uni fun
nonDelayedAlt, PIRTerm uni fun
delayedAlt) ->
              if Bool
lazyCase then PIRTerm uni fun
delayedAlt else PIRTerm uni fun
nonDelayedAlt

        -- See Note [Scott encoding of datatypes]
        -- we need this for the default case body
        PIRType uni
originalResultType <- Type -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
t
        -- See Note [Scott encoding of datatypes]
        -- we're going to delay the body, so the matcher needs to be instantiated at the delayed type
        PIRType uni
resultType <- Bool -> PIRType uni -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Bool -> PIRType uni -> m (PIRType uni)
maybeDelayType Bool
lazyCase PIRType uni
originalResultType
        let instantiated :: PIRTerm uni fun
instantiated = Ann -> PIRTerm uni fun -> PIRType uni -> PIRTerm uni fun
forall tyname name (uni :: * -> *) fun a.
a
-> Term tyname name uni fun a
-> Type tyname uni a
-> Term tyname name uni fun a
PIR.TyInst Ann
annMayInline PIRTerm uni fun
matched PIRType uni
resultType

        let applied :: PIRTerm uni fun
applied = PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp PIRTerm uni fun
instantiated ([(Ann, PIRTerm uni fun)] -> PIRTerm uni fun)
-> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$ (Ann
annMayInline,) (PIRTerm uni fun -> (Ann, PIRTerm uni fun))
-> [PIRTerm uni fun] -> [(Ann, PIRTerm uni fun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PIRTerm uni fun]
branches
        -- See Note [Case expressions and laziness]
        PIRTerm uni fun
mainCase <- Bool -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Bool -> PIRTerm uni fun -> m (PIRTerm uni fun)
maybeForce Bool
lazyCase PIRTerm uni fun
applied

        let binds :: [Binding TyName Name uni fun Ann]
binds =
              [ -- See Note [At patterns]
                Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict VarDecl TyName Name uni Ann
v PIRTerm uni fun
scrutinee'
              , -- Bind the default body, see Note [Sharing DEFAULT bodies]
                Ann
-> Strictness
-> VarDecl TyName Name uni Ann
-> PIRTerm uni fun
-> Binding TyName Name uni fun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> Strictness
-> VarDecl tyname name uni a
-> Term tyname name uni fun a
-> Binding tyname name uni fun a
PIR.TermBind Ann
annMayInline Strictness
PIR.NonStrict (Ann -> Name -> PIRType uni -> VarDecl TyName Name uni Ann
forall tyname name (uni :: * -> *) ann.
ann -> name -> Type tyname uni ann -> VarDecl tyname name uni ann
PIR.VarDecl Ann
annMayInline Name
defName PIRType uni
originalResultType) PIRTerm uni fun
defCompiled
              ]
        PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Ann
-> Recursivity
-> [Binding TyName Name uni fun Ann]
-> PIRTerm uni fun
-> PIRTerm uni fun
forall a tyname name (uni :: * -> *) fun.
a
-> Recursivity
-> [Binding tyname name uni fun a]
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.mkLet Ann
annMayInline Recursivity
PIR.NonRec [Binding TyName Name uni fun Ann]
binds PIRTerm uni fun
mainCase

{- Note [What source locations to cover]
   We try to get as much coverage information as we can out of GHC. This means that
   anything we find in the GHC Core code that hints at a source location will be
   included as a coverage annotation. This has both advantages and disadvantages.
   On the one hand "trying as hard as we can" gives us as much coverage information as
   possible. On the other hand GHC can sometimes do tricky things like tick floating
   that will degrade the quality of the coverage information we get. However, we have
   yet to find any evidence that GHC treats different ticks differently with regards
   to tick floating.
-}

{- Note [Partial type signature for getSourceSpan]
Why is there a partial type signature here? The answer is that we sometimes compile with a patched
GHC provided from haskell.nix that has a slightly busted patch applied to it. That patch changes
the type of the 'Tickish' part of 'Tick'.

Obviously we would eventually like to not have this problem (should be when we go to 9.2), but in
the mean time we'd like things to compile on both the patched and non-patched GHC.

A partial type signature provides a simple solution: GHC will infer different types for the hole
in each case, but since we operate on them in the same way, there's no problem.
-}

-- See Note [What source locations to cover]
-- See Note [Partial type signature for getSourceSpan]

-- | Do your best to try to extract a source span from a tick
getSourceSpan :: Maybe GHC.ModBreaks -> _ -> Maybe GHC.RealSrcSpan
getSourceSpan :: Maybe ModBreaks -> GenTickish pass -> Maybe RealSrcSpan
getSourceSpan Maybe ModBreaks
_ GHC.SourceNote{sourceSpan :: forall (pass :: TickishPass). GenTickish pass -> RealSrcSpan
GHC.sourceSpan = RealSrcSpan
src} = RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
src
getSourceSpan Maybe ModBreaks
_ GHC.ProfNote{profNoteCC :: forall (pass :: TickishPass). GenTickish pass -> CostCentre
GHC.profNoteCC = CostCentre
cc} =
  case CostCentre
cc of
    GHC.NormalCC CCFlavour
_ CcName
_ Module
_ (GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_) -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
    GHC.AllCafsCC Module
_ (GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_)    -> RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
Just RealSrcSpan
sp
    CostCentre
_                                         -> Maybe RealSrcSpan
forall a. Maybe a
Nothing
getSourceSpan Maybe ModBreaks
mmb GHC.HpcTick{tickId :: forall (pass :: TickishPass). GenTickish pass -> Int
GHC.tickId = Int
tid} = do
  ModBreaks
mb <- Maybe ModBreaks
mmb
  let arr :: Array Int SrcSpan
arr = ModBreaks -> Array Int SrcSpan
GHC.modBreaks_locs ModBreaks
mb
      range :: (Int, Int)
range = Array Int SrcSpan -> (Int, Int)
forall i e. Array i e -> (i, i)
Array.bounds Array Int SrcSpan
arr
  GHC.RealSrcSpan RealSrcSpan
sp Maybe BufSpan
_ <- if (Int, Int) -> Int -> Bool
forall a. Ix a => (a, a) -> a -> Bool
Array.inRange (Int, Int)
range Int
tid then SrcSpan -> Maybe SrcSpan
forall a. a -> Maybe a
Just (SrcSpan -> Maybe SrcSpan) -> SrcSpan -> Maybe SrcSpan
forall a b. (a -> b) -> a -> b
$ Array Int SrcSpan
arr Array Int SrcSpan -> Int -> SrcSpan
forall i e. Ix i => Array i e -> i -> e
Array.! Int
tid else Maybe SrcSpan
forall a. Maybe a
Nothing
  RealSrcSpan -> Maybe RealSrcSpan
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return RealSrcSpan
sp
getSourceSpan Maybe ModBreaks
_ GenTickish pass
_ = Maybe RealSrcSpan
forall a. Maybe a
Nothing

getVarSourceSpan :: GHC.Var -> Maybe GHC.RealSrcSpan
getVarSourceSpan :: Id -> Maybe RealSrcSpan
getVarSourceSpan = SrcSpan -> Maybe RealSrcSpan
GHC.srcSpanToRealSrcSpan (SrcSpan -> Maybe RealSrcSpan)
-> (Id -> SrcSpan) -> Id -> Maybe RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> SrcSpan
GHC.nameSrcSpan (Name -> SrcSpan) -> (Id -> Name) -> Id -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Name
GHC.varName

srcSpanIso :: Iso' GHC.RealSrcSpan SrcSpan
srcSpanIso :: Iso' RealSrcSpan SrcSpan
srcSpanIso = (RealSrcSpan -> SrcSpan)
-> (SrcSpan -> RealSrcSpan) -> Iso' RealSrcSpan SrcSpan
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso RealSrcSpan -> SrcSpan
fromGHC SrcSpan -> RealSrcSpan
toGHC
  where
    fromGHC :: RealSrcSpan -> SrcSpan
fromGHC RealSrcSpan
sp =
      SrcSpan
        { srcSpanFile :: String
srcSpanFile = CcName -> String
GHC.unpackFS (RealSrcSpan -> CcName
GHC.srcSpanFile RealSrcSpan
sp)
        , srcSpanSLine :: Int
srcSpanSLine = RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
sp
        , srcSpanSCol :: Int
srcSpanSCol = RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
sp
        , srcSpanELine :: Int
srcSpanELine = RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
sp
        , srcSpanECol :: Int
srcSpanECol = RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
sp
        }
    toGHC :: SrcSpan -> RealSrcSpan
toGHC SrcSpan
sp =
      RealSrcLoc -> RealSrcLoc -> RealSrcSpan
GHC.mkRealSrcSpan
        (CcName -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (SrcSpan -> CcName
fileNameFs SrcSpan
sp) (SrcSpan -> Int
srcSpanSLine SrcSpan
sp) (SrcSpan -> Int
srcSpanSCol SrcSpan
sp))
        (CcName -> Int -> Int -> RealSrcLoc
GHC.mkRealSrcLoc (SrcSpan -> CcName
fileNameFs SrcSpan
sp) (SrcSpan -> Int
srcSpanELine SrcSpan
sp) (SrcSpan -> Int
srcSpanECol SrcSpan
sp))
    fileNameFs :: SrcSpan -> CcName
fileNameFs = String -> CcName
GHC.fsLit (String -> CcName) -> (SrcSpan -> String) -> SrcSpan -> CcName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> String
srcSpanFile

-- | Obviously this function computes a GHC.RealSrcSpan from a CovLoc
toCovLoc :: GHC.RealSrcSpan -> CovLoc
toCovLoc :: RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
sp =
  String -> Int -> Int -> Int -> Int -> CovLoc
CovLoc
    (CcName -> String
GHC.unpackFS (CcName -> String) -> CcName -> String
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> CcName
GHC.srcSpanFile RealSrcSpan
sp)
    (RealSrcSpan -> Int
GHC.srcSpanStartLine RealSrcSpan
sp)
    (RealSrcSpan -> Int
GHC.srcSpanEndLine RealSrcSpan
sp)
    (RealSrcSpan -> Int
GHC.srcSpanStartCol RealSrcSpan
sp)
    (RealSrcSpan -> Int
GHC.srcSpanEndCol RealSrcSpan
sp)

-- Here be dragons:
-- See Note [Tracking coverage and lazyness]
-- See Note [Coverage order]

-- | Annotate a term for coverage
coverageCompile ::
  (CompilingDefault uni fun m ann) =>
  -- | The original expression
  GHC.CoreExpr ->
  -- | The type of the expression
  GHC.Type ->
  -- | The source location of this expression
  GHC.RealSrcSpan ->
  -- | The current term (this is what we add coverage tracking to)
  PIRTerm uni fun ->
  -- | The type of coverage to do next
  CoverageType ->
  m (PIRTerm uni fun)
coverageCompile :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr
-> Type
-> RealSrcSpan
-> PIRTerm uni fun
-> CoverageType
-> m (PIRTerm uni fun)
coverageCompile CoreExpr
originalExpr Type
exprType RealSrcSpan
src PIRTerm uni fun
compiledTerm CoverageType
covT =
  case CoverageType
covT of
    -- Add a location coverage annotation to tell us "we've executed this piece of code"
    CoverageType
LocationCoverage -> do
      CoverageAnnotation
ann <- CovLoc -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> m CoverageAnnotation
addLocationToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src)
      PIRType uni
ty <- Type -> m (PIRType uni)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type -> m (PIRType uni)
compileTypeNorm Type
exprType
      PIRType uni
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Type TyName uni Ann
-> Text -> PIRTerm uni DefaultFun -> m (PIRTerm uni fun)
mkLazyTrace PIRType uni
ty (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
ann) PIRTerm uni fun
PIRTerm uni DefaultFun
compiledTerm

    -- Add two boolean coverage annotations to tell us "this boolean has been True/False respectively"
    -- see Note [Boolean coverage]
    CoverageType
BooleanCoverage -> do
      -- Check if the thing we are compiling is a boolean
      TyThing
bool <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing ''Bool
      TyThing
true <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'True
      TyThing
false <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'False
      let tyHeadName :: Maybe Name
tyHeadName = TyCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyCon -> Name) -> Maybe TyCon -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe TyCon
GHC.tyConAppTyCon_maybe Type
exprType
          headSymName :: Maybe Name
headSymName = Id -> Name
forall a. NamedThing a => a -> Name
GHC.getName (Id -> Name) -> Maybe Id -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
originalExpr
          isTrueOrFalse :: Bool
isTrueOrFalse = case CoreExpr
originalExpr of
            GHC.Var Id
v
              | GHC.DataConWorkId DataCon
dc <- Id -> IdDetails
GHC.idDetails Id
v ->
                  DataCon -> Name
forall a. NamedThing a => a -> Name
GHC.getName DataCon
dc Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
c | TyThing
c <- [TyThing
true, TyThing
false]]
            CoreExpr
_ -> Bool
False

      if Maybe Name
tyHeadName Maybe Name -> Maybe Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Maybe Name
forall a. a -> Maybe a
Just (TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName TyThing
bool) Bool -> Bool -> Bool
|| Bool
isTrueOrFalse
        then PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PIRTerm uni fun
compiledTerm
        else -- Generate the code:
        -- ```
        -- traceBool "<compiledTerm was true>" "<compiledTerm was false>" compiledTerm
        -- ```
        do
          TyThing
traceBoolThing <- Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'traceBool
          case TyThing
traceBoolThing of
            GHC.AnId Id
traceBoolId -> do
              PIRTerm uni fun
traceBoolCompiled <- CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr (CoreExpr -> m (PIRTerm uni fun))
-> CoreExpr -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr
forall b. Id -> Expr b
GHC.Var Id
traceBoolId
              let mkMetadata :: Maybe Name -> CoverageMetadata
mkMetadata = Set Metadata -> CoverageMetadata
CoverageMetadata (Set Metadata -> CoverageMetadata)
-> (Maybe Name -> Set Metadata) -> Maybe Name -> CoverageMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Set Metadata) -> Maybe Name -> Set Metadata
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Metadata -> Set Metadata
forall a. a -> Set a
Set.singleton (Metadata -> Set Metadata)
-> (Name -> Metadata) -> Name -> Set Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Metadata
ApplicationHeadSymbol (String -> Metadata) -> (Name -> String) -> Name -> Metadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
forall a. NamedThing a => a -> String
GHC.getOccString)
              CoverageAnnotation
fc <- CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
addBoolCaseToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src) Bool
False (Maybe Name -> CoverageMetadata
mkMetadata Maybe Name
headSymName)
              CoverageAnnotation
tc <- CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
forall (m :: * -> *).
MonadWriter CoverageIndex m =>
CovLoc -> Bool -> CoverageMetadata -> m CoverageAnnotation
addBoolCaseToCoverageIndex (RealSrcSpan -> CovLoc
toCovLoc RealSrcSpan
src) Bool
True (Maybe Name -> CoverageMetadata
mkMetadata Maybe Name
headSymName)
              PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PIRTerm uni fun -> m (PIRTerm uni fun))
-> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                PIRTerm uni fun -> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PLC.mkIterApp PIRTerm uni fun
traceBoolCompiled ([(Ann, PIRTerm uni fun)] -> PIRTerm uni fun)
-> [(Ann, PIRTerm uni fun)] -> PIRTerm uni fun
forall a b. (a -> b) -> a -> b
$
                  (Ann
annMayInline,)
                    (PIRTerm uni fun -> (Ann, PIRTerm uni fun))
-> [PIRTerm uni fun] -> [(Ann, PIRTerm uni fun)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Ann -> Text -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
tc)
                        , Ann -> Text -> PIRTerm uni fun
forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PLC.mkConstant Ann
annMayInline (String -> Text
T.pack (String -> Text)
-> (CoverageAnnotation -> String) -> CoverageAnnotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoverageAnnotation -> String
forall a. Show a => a -> String
show (CoverageAnnotation -> Text) -> CoverageAnnotation -> Text
forall a b. (a -> b) -> a -> b
$ CoverageAnnotation
fc)
                        , PIRTerm uni fun
compiledTerm
                        ]
            TyThing
_ ->
              (Text -> Error DefaultUni DefaultFun ann)
-> SDoc -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun ann (m :: * -> *) a.
(MonadError (CompileError uni fun ann) m,
 MonadReader (CompileContext uni fun) m) =>
(Text -> Error uni fun ann) -> SDoc -> m a
throwSd Text -> Error DefaultUni DefaultFun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError (SDoc -> m (PIRTerm uni fun)) -> SDoc -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
                SDoc
"Lookup of traceBool failed. Expected to get AnId but saw: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
GHC.<+> TyThing -> SDoc
forall a. Outputable a => a -> SDoc
GHC.ppr TyThing
traceBoolThing
  where
    findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id
    findHeadSymbol :: CoreExpr -> Maybe Id
findHeadSymbol (GHC.Var Id
n)    = Id -> Maybe Id
forall a. a -> Maybe a
Just Id
n
    findHeadSymbol (GHC.App CoreExpr
t CoreExpr
_)  = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
    findHeadSymbol (GHC.Lam Id
_ CoreExpr
t)  = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
    findHeadSymbol (GHC.Tick CoreTickish
_ CoreExpr
t) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
    findHeadSymbol (GHC.Let Bind Id
_ CoreExpr
t)  = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
    findHeadSymbol (GHC.Cast CoreExpr
t CoercionR
_) = CoreExpr -> Maybe Id
findHeadSymbol CoreExpr
t
    findHeadSymbol CoreExpr
_              = Maybe Id
forall a. Maybe a
Nothing

-- | We cannot compile the unfolding of `GHC.Num.Integer.integerNegate`, which is
-- important because GHC inserts calls to it when it sees negations, even negations
-- of literals (unless NegativeLiterals is on, which it usually isn't). So we directly
-- define a PIR term for it: @integerNegate = \x -> 0 - x@.
defineIntegerNegate :: (CompilingDefault PLC.DefaultUni fun m ann) => m ()
defineIntegerNegate :: forall fun (m :: * -> *) ann.
CompilingDefault DefaultUni fun m ann =>
m ()
defineIntegerNegate = do
  Id
ghcId <- (() :: Constraint) => TyThing -> Id
TyThing -> Id
GHC.tyThingId (TyThing -> Id) -> m TyThing -> m Id
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'GHC.Num.Integer.integerNegate
  -- Always inline `integerNegate`.
  -- `let integerNegate = \x -> 0 - x in integerNegate 1 + integerNegate 2`
  -- is much more expensive than `(-1) + (-2)`. The inliner cannot currently
  -- make this transformation without `annAlwaysInline`, because it is not aware
  -- of constant folding.
  VarDecl TyName Name DefaultUni Ann
var <- Ann -> Id -> m (VarDecl TyName Name DefaultUni Ann)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
Ann -> Id -> m (PLCVar uni)
compileVarFresh Ann
annAlwaysInline Id
ghcId
  let ann :: Ann
ann = Ann
annMayInline
  Name
x <- Text -> m Name
forall (m :: * -> *). MonadQuote m => Text -> m Name
safeFreshName Text
"x"
  let
    -- body = 0 - x
    body :: Term TyName Name DefaultUni DefaultFun Ann
body =
      Ann
-> Name
-> PLCType DefaultUni
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a
-> name
-> Type tyname uni a
-> Term tyname name uni fun a
-> Term tyname name uni fun a
PIR.LamAbs Ann
ann Name
x (forall a (x :: a) (uni :: * -> *) ann tyname.
HasTypeLevel uni x =>
ann -> Type tyname uni ann
PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni Ann
ann) (Term TyName Name DefaultUni DefaultFun Ann
 -> Term TyName Name DefaultUni DefaultFun Ann)
-> Term TyName Name DefaultUni DefaultFun Ann
-> Term TyName Name DefaultUni DefaultFun Ann
forall a b. (a -> b) -> a -> b
$
        Term TyName Name DefaultUni DefaultFun Ann
-> [(Ann, Term TyName Name DefaultUni DefaultFun Ann)]
-> Term TyName Name DefaultUni DefaultFun Ann
forall (term :: * -> *) tyname name (uni :: * -> *) fun ann.
TermLike term tyname name uni fun =>
term ann -> [(ann, term ann)] -> term ann
PIR.mkIterApp
          (Ann -> DefaultFun -> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a -> fun -> Term tyname name uni fun a
PIR.Builtin Ann
ann DefaultFun
PLC.SubtractInteger)
          [ (Ann
ann, forall a (uni :: * -> *) fun (term :: * -> *) tyname name ann.
(TermLike term tyname name uni fun, HasTermLevel uni a) =>
ann -> a -> term ann
PIR.mkConstant @Integer Ann
ann Integer
0)
          , (Ann
ann, Ann -> Name -> Term TyName Name DefaultUni DefaultFun Ann
forall tyname name (uni :: * -> *) fun a.
a -> name -> Term tyname name uni fun a
PIR.Var Ann
ann Name
x)
          ]
    def :: TermDefWithStrictness DefaultUni DefaultFun Ann
def = VarDecl TyName Name DefaultUni Ann
-> (Term TyName Name DefaultUni DefaultFun Ann, Strictness)
-> TermDefWithStrictness DefaultUni DefaultFun Ann
forall var val. var -> val -> Def var val
PIR.Def VarDecl TyName Name DefaultUni Ann
var (Term TyName Name DefaultUni DefaultFun Ann
body, Strictness
PIR.Strict)
  LexName
-> TermDefWithStrictness DefaultUni DefaultFun Ann
-> Set LexName
-> m ()
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
key -> TermDefWithStrictness uni fun ann -> Set key -> m ()
PIR.defineTerm (Name -> LexName
LexName Name
GHC.integerNegateName) TermDefWithStrictness DefaultUni DefaultFun Ann
def Set LexName
forall a. Monoid a => a
mempty

lookupIntegerNegate :: (Compiling uni fun m ann) => m (PIRTerm uni fun)
lookupIntegerNegate :: forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
m (PIRTerm uni fun)
lookupIntegerNegate = do
  Name
ghcName <- TyThing -> Name
forall a. NamedThing a => a -> Name
GHC.getName (TyThing -> Name) -> m TyThing -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> m TyThing
forall (uni :: * -> *) fun (m :: * -> *) ann.
Compiling uni fun m ann =>
Name -> m TyThing
getThing 'GHC.Num.Integer.integerNegate
  Ann -> LexName -> m (Maybe (PIRTerm uni fun))
forall key (uni :: * -> *) fun ann (m :: * -> *).
MonadDefs key uni fun ann m =>
ann -> key -> m (Maybe (Term TyName Name uni fun ann))
PIR.lookupTerm Ann
annMayInline (Name -> LexName
LexName Name
ghcName) m (Maybe (PIRTerm uni fun))
-> (Maybe (PIRTerm uni fun) -> m (PIRTerm uni fun))
-> m (PIRTerm uni fun)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just PIRTerm uni fun
t -> PIRTerm uni fun -> m (PIRTerm uni fun)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PIRTerm uni fun
t
    Maybe (PIRTerm uni fun)
Nothing -> Error uni fun ann -> m (PIRTerm uni fun)
forall c e (m :: * -> *) a.
MonadError (WithContext c e) m =>
e -> m a
throwPlain (Error uni fun ann -> m (PIRTerm uni fun))
-> Error uni fun ann -> m (PIRTerm uni fun)
forall a b. (a -> b) -> a -> b
$
      Text -> Error uni fun ann
forall (uni :: * -> *) fun a. Text -> Error uni fun a
CompilationError Text
"Cannot find the definition of integerNegate. Please file a bug report."

compileExprWithDefs ::
  (CompilingDefault uni fun m ann) =>
  GHC.CoreExpr ->
  m (PIRTerm uni fun)
compileExprWithDefs :: forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExprWithDefs CoreExpr
e = do
  m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
m ()
defineBuiltinTypes
  m ()
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
m ()
defineBuiltinTerms
  m ()
forall fun (m :: * -> *) ann.
CompilingDefault DefaultUni fun m ann =>
m ()
defineIntegerNegate
  CoreExpr -> m (PIRTerm uni fun)
forall (uni :: * -> *) fun (m :: * -> *) ann.
CompilingDefault uni fun m ann =>
CoreExpr -> m (PIRTerm uni fun)
compileExpr CoreExpr
e

{- Note [We always need DEFAULT]
GHC can be clever and omit case alternatives sometimes, typically when the typechecker says a case
is impossible due to GADT cleverness or similar.
We can't do this: we always need to put in all the case alternatives. In particular, that means
we always want a DEFAULT case to fall back on if GHC doesn't provide a specific alternative for
a data constructor.
The easiest way to ensure that we always have a DEFAULT case is just to put one in if it's missing.
-}

{- Note [Sharing DEFAULT bodies]
Consider the following program:
```
data A = B | C | D
f a = case a of
  B -> 1
  _ -> 2
```
How many times will the literal 2 appear in the resulting PIR program? Naively... twice!
We need to make all the cases explicit, so that means we actually need to *duplicate*
the default case for every alternative that needs it, i.e. we end up with something more like
```
f a = case a of
  B -> 1
  C -> 2
  D -> 2
```
This should set of alarm bells: any time we duplicate things we can end up with exponential
programs if the construct is nested. And that can happen - one example is that usage of
pattern synonyms tends to generate code like:
```
f a = case pattern_synonym_func1 of
  pat1 -> ...
  _ -> case pattern_synonym_func2 of
    pat2 -> ...
    _ -> case ...
```
So a case expression with 8 pattern synonyms would generate 2^8 copies of the final default
case - pretty bad!
The solution is straightforward: share the default case. That means we produce a program more
like:
```
f a = let defaultBody = 2 in case a of
  B -> 1
  C -> defaultBody
  D -> defaultBody
```
Then the inliner can inline it as appropriate.
-}