{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017-2022, Google Inc.,
                     2017-2026, QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>
-}

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Clash.GHC.Evaluator.Primitives.Clash.Sized.RTree
  ( primitives
  ) where

import           Control.Monad.Trans.Except (runExcept)
import qualified Data.Either         as Either
import           Data.Text           (Text)

import           Clash.Core.Evaluator.Types
import Clash.Core.HasType (piResultTys)
import           Clash.Core.Literal  (Literal (..))
import Clash.Core.Term (Term (..), mkApps)
import Clash.Core.Type
  (Type (..),
   LitTy (..),
   TypeView (..),
   mkTyConApp,
   splitFunForallTy,
   tyView)
import Clash.Core.TyCon (tyConDataCons)
import Clash.Core.Util (mkRTree, tyNatSize)
import qualified Clash.Data.UniqMap as UniqMap
import Clash.Util (textNameLit)

import qualified Clash.Sized.RTree

import Clash.GHC.Evaluator.Primitive.Util

primitives :: [(Text, PrimStep)]
primitives :: [(Text, PrimStep)]
primitives =
--------
-- RTree
--------
  [ Text -> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
primStepEntry $(textNameLit 'Clash.Sized.RTree.textract) ((PrimStepContext -> Maybe Machine) -> (Text, PrimStep))
-> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
forall a b. (a -> b) -> a -> b
$ \case
      PrimStepContext{Bool
[Type]
[Value]
Type
TyConMap
Machine
PrimInfo
Term -> Maybe Machine
Term -> Term
Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
Type -> Integer -> (Natural -> Natural) -> Term
Type -> [Integer] -> ([Natural] -> Term) -> Term
Machine -> Term -> Maybe Machine
tcm :: TyConMap
isSubj :: Bool
pInfo :: PrimInfo
tys :: [Type]
args :: [Value]
mach :: Machine
ty :: Type
checkNaturalRange1 :: Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
checkNaturalRange :: Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: Term -> Maybe Machine
reduceWith :: Machine -> Term -> Maybe Machine
reduceWHNF :: Term -> Maybe Machine
reduceWHNF' :: Machine -> Term -> Maybe Machine
catchDivByZero :: Term -> Term
catchErrorCall :: Term -> Term
tcm :: PrimStepContext -> TyConMap
isSubj :: PrimStepContext -> Bool
pInfo :: PrimStepContext -> PrimInfo
tys :: PrimStepContext -> [Type]
args :: PrimStepContext -> [Value]
mach :: PrimStepContext -> Machine
ty :: PrimStepContext -> Type
checkNaturalRange1 :: PrimStepContext -> Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: PrimStepContext
-> Type
-> Integer
-> Integer
-> (Natural -> Natural -> Natural)
-> Term
checkNaturalRange :: PrimStepContext -> Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: PrimStepContext -> Term -> Maybe Machine
reduceWith :: PrimStepContext -> Machine -> Term -> Maybe Machine
reduceWHNF :: PrimStepContext -> Term -> Maybe Machine
reduceWHNF' :: PrimStepContext -> Machine -> Term -> Maybe Machine
catchDivByZero :: PrimStepContext -> Term -> Term
catchErrorCall :: PrimStepContext -> Term -> Term
..}
        | Bool
isSubj
        , [DC DataCon
_ [Either Term Type]
tArgs] <- [Value]
args
        -> Term -> Maybe Machine
reduceWHNF ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
      PrimStepContext
_ -> Maybe Machine
forall a. Maybe a
Nothing

  , Text -> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
primStepEntry $(textNameLit 'Clash.Sized.RTree.tsplit) ((PrimStepContext -> Maybe Machine) -> (Text, PrimStep))
-> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
forall a b. (a -> b) -> a -> b
$ \case
      PrimStepContext{Bool
[Type]
[Value]
Type
TyConMap
Machine
PrimInfo
Term -> Maybe Machine
Term -> Term
Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
Type -> Integer -> (Natural -> Natural) -> Term
Type -> [Integer] -> ([Natural] -> Term) -> Term
Machine -> Term -> Maybe Machine
tcm :: PrimStepContext -> TyConMap
isSubj :: PrimStepContext -> Bool
pInfo :: PrimStepContext -> PrimInfo
tys :: PrimStepContext -> [Type]
args :: PrimStepContext -> [Value]
mach :: PrimStepContext -> Machine
ty :: PrimStepContext -> Type
checkNaturalRange1 :: PrimStepContext -> Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: PrimStepContext
-> Type
-> Integer
-> Integer
-> (Natural -> Natural -> Natural)
-> Term
checkNaturalRange :: PrimStepContext -> Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: PrimStepContext -> Term -> Maybe Machine
reduceWith :: PrimStepContext -> Machine -> Term -> Maybe Machine
reduceWHNF :: PrimStepContext -> Term -> Maybe Machine
reduceWHNF' :: PrimStepContext -> Machine -> Term -> Maybe Machine
catchDivByZero :: PrimStepContext -> Term -> Term
catchErrorCall :: PrimStepContext -> Term -> Term
tcm :: TyConMap
isSubj :: Bool
pInfo :: PrimInfo
tys :: [Type]
args :: [Value]
mach :: Machine
ty :: Type
checkNaturalRange1 :: Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
checkNaturalRange :: Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: Term -> Maybe Machine
reduceWith :: Machine -> Term -> Maybe Machine
reduceWHNF :: Term -> Maybe Machine
reduceWHNF' :: Machine -> Term -> Maybe Machine
catchDivByZero :: Term -> Term
catchErrorCall :: Term -> Term
..}
        | Bool
isSubj
        , Type
dTy : Type
aTy : [Type]
_ <- [Type]
tys
        , [DC DataCon
_ [Either Term Type]
tArgs] <- [Value]
args
        , ([Either TyVar Type]
tyArgs,Type -> TypeView
tyView -> TyConApp TyConName
tupTcNm [Type]
_) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
        , TyConApp TyConName
treeTcNm [Type]
_ <- Type -> TypeView
tyView ([Either TyVar Type] -> [Type]
forall a b. [Either a b] -> [b]
Either.rights [Either TyVar Type]
tyArgs [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
0)
        -> let (Just TyCon
tupTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
tupTcNm TyConMap
tcm
               [DataCon
tupDc]      = TyCon -> [DataCon]
tyConDataCons TyCon
tupTc
           in  Term -> Maybe Machine
reduce (Term -> Maybe Machine) -> Term -> Maybe Machine
forall a b. (a -> b) -> a -> b
$
               Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
tupDc)
                      [Type -> Either Term Type
forall a b. b -> Either a b
Right (TyConName -> [Type] -> Type
mkTyConApp TyConName
treeTcNm [Type
dTy,Type
aTy])
                      ,Type -> Either Term Type
forall a b. b -> Either a b
Right (TyConName -> [Type] -> Type
mkTyConApp TyConName
treeTcNm [Type
dTy,Type
aTy])
                      ,Term -> Either Term Type
forall a b. a -> Either a b
Left ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
                      ,Term -> Either Term Type
forall a b. a -> Either a b
Left ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
2)
                      ]
      PrimStepContext
_ -> Maybe Machine
forall a. Maybe a
Nothing

  , Text -> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
primStepEntry $(textNameLit 'Clash.Sized.RTree.tdfold) ((PrimStepContext -> Maybe Machine) -> (Text, PrimStep))
-> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
forall a b. (a -> b) -> a -> b
$ \case
      PrimStepContext{Bool
[Type]
[Value]
Type
TyConMap
Machine
PrimInfo
Term -> Maybe Machine
Term -> Term
Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
Type -> Integer -> (Natural -> Natural) -> Term
Type -> [Integer] -> ([Natural] -> Term) -> Term
Machine -> Term -> Maybe Machine
tcm :: PrimStepContext -> TyConMap
isSubj :: PrimStepContext -> Bool
pInfo :: PrimStepContext -> PrimInfo
tys :: PrimStepContext -> [Type]
args :: PrimStepContext -> [Value]
mach :: PrimStepContext -> Machine
ty :: PrimStepContext -> Type
checkNaturalRange1 :: PrimStepContext -> Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: PrimStepContext
-> Type
-> Integer
-> Integer
-> (Natural -> Natural -> Natural)
-> Term
checkNaturalRange :: PrimStepContext -> Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: PrimStepContext -> Term -> Maybe Machine
reduceWith :: PrimStepContext -> Machine -> Term -> Maybe Machine
reduceWHNF :: PrimStepContext -> Term -> Maybe Machine
reduceWHNF' :: PrimStepContext -> Machine -> Term -> Maybe Machine
catchDivByZero :: PrimStepContext -> Term -> Term
catchErrorCall :: PrimStepContext -> Term -> Term
tcm :: TyConMap
isSubj :: Bool
pInfo :: PrimInfo
tys :: [Type]
args :: [Value]
mach :: Machine
ty :: Type
checkNaturalRange1 :: Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
checkNaturalRange :: Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: Term -> Maybe Machine
reduceWith :: Machine -> Term -> Maybe Machine
reduceWHNF :: Term -> Maybe Machine
reduceWHNF' :: Machine -> Term -> Maybe Machine
catchDivByZero :: Term -> Term
catchErrorCall :: Term -> Term
..}
        | Bool
isSubj
        , Type
pTy : Type
kTy : Type
aTy : [Type]
_ <- [Type]
tys
        , Value
_ : Value
p : Value
f : Value
g : Value
ts : [Value]
_ <- [Value]
args
        , DC DataCon
_ [Either Term Type]
tArgs <- Value
ts
        , Right Integer
k' <- Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
tcm Type
kTy)
        -> case Integer
k' of
             Integer
0 -> Term -> Maybe Machine
reduceWHNF (Term -> [Either Term Type] -> Term
mkApps (Value -> Term
valToTerm Value
f) [Term -> Either Term Type
forall a b. a -> Either a b
Left ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)])
             Integer
_ -> let k'ty :: Type
k'ty = LitTy -> Type
LitTy (Integer -> LitTy
NumTy (Integer
k'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1))
                      ([Either TyVar Type]
tyArgs,Type
_)  = Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
                      ([Either TyVar Type]
tyArgs',Type
_) = Type -> ([Either TyVar Type], Type)
splitFunForallTy ([Either TyVar Type] -> [Type]
forall a b. [Either a b] -> [b]
Either.rights [Either TyVar Type]
tyArgs [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
3)
                      TyConApp TyConName
snatTcNm [Type]
_ = Type -> TypeView
tyView ([Either TyVar Type] -> [Type]
forall a b. [Either a b] -> [b]
Either.rights [Either TyVar Type]
tyArgs' [Type] -> Int -> Type
forall a. HasCallStack => [a] -> Int -> a
!! Int
0)
                      Just TyCon
snatTc = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
snatTcNm TyConMap
tcm
                      [DataCon
snatDc]    = TyCon -> [DataCon]
tyConDataCons TyCon
snatTc
                  in  Term -> Maybe Machine
reduceWHNF (Term -> Maybe Machine) -> Term -> Maybe Machine
forall a b. (a -> b) -> a -> b
$
                      Term -> [Either Term Type] -> Term
mkApps (Value -> Term
valToTerm Value
g)
                             [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
k'ty
                             ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Term -> [Either Term Type] -> Term
mkApps (DataCon -> Term
Data DataCon
snatDc)
                                           [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
k'ty
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Literal -> Term
Literal (Integer -> Literal
NaturalLiteral (Integer
k'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)))])
                             ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo)
                                           [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
pTy
                                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
k'ty
                                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
aTy
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Literal -> Term
Literal (Integer -> Literal
NaturalLiteral (Integer
k'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)))
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
p)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
f)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
g)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
1)
                                           ])
                             ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Term -> [Either Term Type] -> Term
mkApps (PrimInfo -> Term
Prim PrimInfo
pInfo)
                                           [Type -> Either Term Type
forall a b. b -> Either a b
Right Type
pTy
                                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
k'ty
                                           ,Type -> Either Term Type
forall a b. b -> Either a b
Right Type
aTy
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Literal -> Term
Literal (Integer -> Literal
NaturalLiteral (Integer
k'Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
1)))
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
p)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
f)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left (Value -> Term
valToTerm Value
g)
                                           ,Term -> Either Term Type
forall a b. a -> Either a b
Left ([Either Term Type] -> [Term]
forall a b. [Either a b] -> [a]
Either.lefts [Either Term Type]
tArgs [Term] -> Int -> Term
forall a. HasCallStack => [a] -> Int -> a
!! Int
2)
                                           ])
                             ]
      PrimStepContext
_ -> Maybe Machine
forall a. Maybe a
Nothing

  , Text -> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
primStepEntry $(textNameLit 'Clash.Sized.RTree.treplicate) ((PrimStepContext -> Maybe Machine) -> (Text, PrimStep))
-> (PrimStepContext -> Maybe Machine) -> (Text, PrimStep)
forall a b. (a -> b) -> a -> b
$ \case
      PrimStepContext{Bool
[Type]
[Value]
Type
TyConMap
Machine
PrimInfo
Term -> Maybe Machine
Term -> Term
Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
Type -> Integer -> (Natural -> Natural) -> Term
Type -> [Integer] -> ([Natural] -> Term) -> Term
Machine -> Term -> Maybe Machine
tcm :: PrimStepContext -> TyConMap
isSubj :: PrimStepContext -> Bool
pInfo :: PrimStepContext -> PrimInfo
tys :: PrimStepContext -> [Type]
args :: PrimStepContext -> [Value]
mach :: PrimStepContext -> Machine
ty :: PrimStepContext -> Type
checkNaturalRange1 :: PrimStepContext -> Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: PrimStepContext
-> Type
-> Integer
-> Integer
-> (Natural -> Natural -> Natural)
-> Term
checkNaturalRange :: PrimStepContext -> Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: PrimStepContext -> Term -> Maybe Machine
reduceWith :: PrimStepContext -> Machine -> Term -> Maybe Machine
reduceWHNF :: PrimStepContext -> Term -> Maybe Machine
reduceWHNF' :: PrimStepContext -> Machine -> Term -> Maybe Machine
catchDivByZero :: PrimStepContext -> Term -> Term
catchErrorCall :: PrimStepContext -> Term -> Term
tcm :: TyConMap
isSubj :: Bool
pInfo :: PrimInfo
tys :: [Type]
args :: [Value]
mach :: Machine
ty :: Type
checkNaturalRange1 :: Type -> Integer -> (Natural -> Natural) -> Term
checkNaturalRange2 :: Type
-> Integer -> Integer -> (Natural -> Natural -> Natural) -> Term
checkNaturalRange :: Type -> [Integer] -> ([Natural] -> Term) -> Term
reduce :: Term -> Maybe Machine
reduceWith :: Machine -> Term -> Maybe Machine
reduceWHNF :: Term -> Maybe Machine
reduceWHNF' :: Machine -> Term -> Maybe Machine
catchDivByZero :: Term -> Term
catchErrorCall :: Term -> Term
..}
        | Bool
isSubj
        , let ty' :: Type
ty' = HasCallStack => TyConMap -> Type -> [Type] -> Type
TyConMap -> Type -> [Type] -> Type
piResultTys TyConMap
tcm Type
ty [Type]
tys
        , ([Either TyVar Type]
_,Type -> TypeView
tyView -> TyConApp TyConName
treeTcNm [Type
lenTy,Type
argTy]) <- Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty'
        , Right Integer
len <- Except String Integer -> Either String Integer
forall e a. Except e a -> Either e a
runExcept (TyConMap -> Type -> Except String Integer
tyNatSize TyConMap
tcm Type
lenTy)
        -> let (Just TyCon
treeTc) = TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup TyConName
treeTcNm TyConMap
tcm
               [DataCon
lrCon,DataCon
brCon] = TyCon -> [DataCon]
tyConDataCons TyCon
treeTc
           in  Term -> Maybe Machine
reduce (DataCon -> DataCon -> Type -> Integer -> [Term] -> Term
mkRTree DataCon
lrCon DataCon
brCon Type
argTy Integer
len (Int -> Term -> [Term]
forall a. Int -> a -> [a]
replicate (Int
2Int -> Integer -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
len) (Value -> Term
valToTerm ([Value] -> Value
forall a. HasCallStack => [a] -> a
last [Value]
args))))
      PrimStepContext
_ -> Maybe Machine
forall a. Maybe a
Nothing

  ]