{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}

-- | IR loosely based on Appel book.
module Kempe.IR ( writeModule
                , Stmt (..)
                , Exp (..)
                , RelBinOp (..)
                , IntBinOp (..)
                , BoolBinOp (..)
                , Label
                , Temp (..)
                , runTempM
                , TempM
                , prettyIR
                , WriteSt (..)
                , size
                ) where

import           Control.DeepSeq            (NFData)
import           Data.Foldable              (toList)
import           Data.List.NonEmpty         (NonEmpty)
import qualified Data.List.NonEmpty         as NE
-- strict b/c it's faster according to benchmarks
import           Control.Monad.State.Strict (State, gets, modify, runState)
import           Data.Bifunctor             (second)
import qualified Data.ByteString            as BS
import qualified Data.ByteString.Lazy       as BSL
import           Data.Foldable.Ext
import           Data.Int                   (Int64, Int8)
import qualified Data.IntMap                as IM
import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
import           Data.Word                  (Word8)
import           GHC.Generics               (Generic)
import           Kempe.AST
import           Kempe.Name
import           Kempe.Unique
import           Lens.Micro                 (Lens')
import           Lens.Micro.Mtl             (modifying)
import           Prettyprinter              (Doc, Pretty (pretty), braces, brackets, colon, concatWith, hardline, parens, (<+>))
import           Prettyprinter.Ext

type Label = Word

data Temp = Temp64 !Int
          | Temp8 !Int
          | DataPointer -- RBP on x86 and x19 on aarch64?
          deriving (Temp -> Temp -> Bool
(Temp -> Temp -> Bool) -> (Temp -> Temp -> Bool) -> Eq Temp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Temp -> Temp -> Bool
$c/= :: Temp -> Temp -> Bool
== :: Temp -> Temp -> Bool
$c== :: Temp -> Temp -> Bool
Eq, (forall x. Temp -> Rep Temp x)
-> (forall x. Rep Temp x -> Temp) -> Generic Temp
forall x. Rep Temp x -> Temp
forall x. Temp -> Rep Temp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Temp x -> Temp
$cfrom :: forall x. Temp -> Rep Temp x
Generic, Temp -> ()
(Temp -> ()) -> NFData Temp
forall a. (a -> ()) -> NFData a
rnf :: Temp -> ()
$crnf :: Temp -> ()
NFData)

instance Pretty Temp where
    pretty :: Temp -> Doc ann
pretty (Temp64 Int
i)  = Doc ann
"t_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
    pretty (Temp8 Int
i)   = Doc ann
"t8_" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i
    pretty Temp
DataPointer = Doc ann
"datapointer"

data WriteSt = WriteSt { WriteSt -> [Label]
wlabels :: [Label]
                       , WriteSt -> [Int]
temps   :: [Int]
                       }

data TempSt = TempSt { TempSt -> [Label]
labels     :: [Label]
                     , TempSt -> [Int]
tempSupply :: [Int]
                     , TempSt -> IntMap Label
atLabels   :: IM.IntMap Label
                     -- TODO: type sizes in state
                     }

asWriteSt :: TempSt -> WriteSt
asWriteSt :: TempSt -> WriteSt
asWriteSt (TempSt [Label]
ls [Int]
ts IntMap Label
_) = [Label] -> [Int] -> WriteSt
WriteSt [Label]
ls [Int]
ts

runTempM :: TempM a -> (a, WriteSt)
runTempM :: TempM a -> (a, WriteSt)
runTempM = (TempSt -> WriteSt) -> (a, TempSt) -> (a, WriteSt)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second TempSt -> WriteSt
asWriteSt ((a, TempSt) -> (a, WriteSt))
-> (TempM a -> (a, TempSt)) -> TempM a -> (a, WriteSt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TempM a -> TempSt -> (a, TempSt))
-> TempSt -> TempM a -> (a, TempSt)
forall a b c. (a -> b -> c) -> b -> a -> c
flip TempM a -> TempSt -> (a, TempSt)
forall s a. State s a -> s -> (a, s)
runState ([Label] -> [Int] -> IntMap Label -> TempSt
TempSt [Label
1..] [Int
1..] IntMap Label
forall a. Monoid a => a
mempty)

atLabelsLens :: Lens' TempSt (IM.IntMap Label)
atLabelsLens :: (IntMap Label -> f (IntMap Label)) -> TempSt -> f TempSt
atLabelsLens IntMap Label -> f (IntMap Label)
f TempSt
s = (IntMap Label -> TempSt) -> f (IntMap Label) -> f TempSt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntMap Label
x -> TempSt
s { atLabels :: IntMap Label
atLabels = IntMap Label
x }) (IntMap Label -> f (IntMap Label)
f (TempSt -> IntMap Label
atLabels TempSt
s))

nextLabels :: TempSt -> TempSt
nextLabels :: TempSt -> TempSt
nextLabels (TempSt [Label]
ls [Int]
ts IntMap Label
ats) = [Label] -> [Int] -> IntMap Label -> TempSt
TempSt ([Label] -> [Label]
forall a. [a] -> [a]
tail [Label]
ls) [Int]
ts IntMap Label
ats

nextTemps :: TempSt -> TempSt
nextTemps :: TempSt -> TempSt
nextTemps (TempSt [Label]
ls [Int]
ts IntMap Label
ats) = [Label] -> [Int] -> IntMap Label -> TempSt
TempSt [Label]
ls ([Int] -> [Int]
forall a. [a] -> [a]
tail [Int]
ts) IntMap Label
ats

type TempM = State TempSt

getTemp :: TempM Int
getTemp :: TempM Int
getTemp = (TempSt -> Int) -> TempM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Int] -> Int
forall a. [a] -> a
head ([Int] -> Int) -> (TempSt -> [Int]) -> TempSt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TempSt -> [Int]
tempSupply) TempM Int -> StateT TempSt Identity () -> TempM Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (TempSt -> TempSt) -> StateT TempSt Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify TempSt -> TempSt
nextTemps

getTemp64 :: TempM Temp
getTemp64 :: TempM Temp
getTemp64 = Int -> Temp
Temp64 (Int -> Temp) -> TempM Int -> TempM Temp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TempM Int
getTemp

getTemp8 :: TempM Temp
getTemp8 :: TempM Temp
getTemp8 = Int -> Temp
Temp8 (Int -> Temp) -> TempM Int -> TempM Temp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TempM Int
getTemp

newLabel :: TempM Label
newLabel :: TempM Label
newLabel = (TempSt -> Label) -> TempM Label
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([Label] -> Label
forall a. [a] -> a
head ([Label] -> Label) -> (TempSt -> [Label]) -> TempSt -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TempSt -> [Label]
labels) TempM Label -> StateT TempSt Identity () -> TempM Label
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* (TempSt -> TempSt) -> StateT TempSt Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify TempSt -> TempSt
nextLabels

broadcastName :: Unique -> TempM Label
broadcastName :: Unique -> TempM Label
broadcastName (Unique Int
i) = do
    Label
l <- TempM Label
newLabel
    ASetter TempSt TempSt (IntMap Label) (IntMap Label)
-> (IntMap Label -> IntMap Label) -> StateT TempSt Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
modifying ASetter TempSt TempSt (IntMap Label) (IntMap Label)
Lens' TempSt (IntMap Label)
atLabelsLens (Int -> Label -> IntMap Label -> IntMap Label
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i Label
l)
    Label -> TempM Label
forall (f :: * -> *) a. Applicative f => a -> f a
pure Label
l

lookupName :: Name a -> TempM Label
lookupName :: Name a -> TempM Label
lookupName (Name Text
_ (Unique Int
i) a
_) =
    (TempSt -> Label) -> TempM Label
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
        (Label -> Int -> IntMap Label -> Label
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault ([Char] -> Label
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in IR phase: could not look find label for name") Int
i (IntMap Label -> Label)
-> (TempSt -> IntMap Label) -> TempSt -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TempSt -> IntMap Label
atLabels)

prettyIR :: [Stmt] -> Doc ann
prettyIR :: [Stmt] -> Doc ann
prettyIR = (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (\Doc ann
x Doc ann
y -> Doc ann
x Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
y) ([Doc ann] -> Doc ann)
-> ([Stmt] -> [Doc ann]) -> [Stmt] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Stmt -> Doc ann) -> [Stmt] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Stmt -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

prettyLabel :: Label -> Doc ann
prettyLabel :: Label -> Doc ann
prettyLabel Label
l = Doc ann
"kmp" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Label
l

instance Pretty Stmt where
    pretty :: Stmt -> Doc ann
pretty (Labeled Label
l)           = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon
    pretty (Jump Label
l)              = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"j" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)
    pretty (CCall MonoStackType
ty ByteString
bs)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"C" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
decodeUtf8 (ByteString -> ByteString
BSL.toStrict ByteString
bs)) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (MonoStackType -> Doc ann
forall a. MonoStackType -> Doc a
prettyMonoStackType  MonoStackType
ty))
    pretty (KCall Label
l)             = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"call" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)
    pretty Stmt
Ret                   = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"ret"
    pretty (MovTemp Temp
t Exp
e)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"movtemp" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Temp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Temp
t Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (MovMem Exp
e Int64
_ Exp
e')       = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"movmem" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e') -- TODO: maybe print size?
    pretty (CJump Exp
e Label
l Label
l')        = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"cjump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l')
    pretty (WrapKCall ABI
_ MonoStackType
ty ByteString
fn Label
l) = Doc ann
forall ann. Doc ann
hardline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"export" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> Text
decodeUtf8 ByteString
fn) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
braces (MonoStackType -> Doc ann
forall a. MonoStackType -> Doc a
prettyMonoStackType MonoStackType
ty) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l
    pretty (MJump Exp
e Label
l)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"mjump" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall ann. Label -> Doc ann
prettyLabel Label
l)

instance Pretty Exp where
    pretty :: Exp -> Doc ann
pretty (ConstInt Int64
i)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"int" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
i)
    pretty (ConstInt8 Int8
i)          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"int8" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int8 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int8
i)
    pretty (ConstWord Label
n)          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"word" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Label -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Label
n)
    pretty (ConstBool Bool
False)      = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"bool false"
    pretty (ConstBool Bool
True)       = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens Doc ann
"bool true"
    pretty (Reg Temp
t)                = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"reg" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Temp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Temp
t)
    pretty (Mem Int64
sz Exp
e)             = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"mem" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Int64 -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int64
sz) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (ExprIntBinOp IntBinOp
op Exp
e Exp
e') = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (IntBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty IntBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (ExprIntRel RelBinOp
op Exp
e Exp
e')   = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (RelBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty RelBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (ConstTag Word8
b)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"tag" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Word8 -> Doc ann
forall a ann. (Integral a, Show a) => a -> Doc ann
prettyHex Word8
b)
    pretty (BoolBinOp BoolBinOp
op Exp
e Exp
e')    = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (BoolBinOp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty BoolBinOp
op Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')
    pretty (IntNegIR Exp
e)           = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"~" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (PopcountIR Exp
e)         = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"popcount" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    pretty (EqByte Exp
e Exp
e')          = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"=b" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Exp -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Exp
e')

data Stmt = Labeled Label
          | Jump Label
          -- conditional jump for ifs
          | CJump Exp Label Label
          | MJump Exp Label
          | CCall MonoStackType BSL.ByteString
          | KCall Label -- KCall is a jump to a Kempe procedure
          | WrapKCall ABI MonoStackType BS.ByteString Label
          | MovTemp Temp Exp -- put e in temp
          | MovMem Exp Int64 Exp -- store e2 at address given by e1
          | Ret
          deriving ((forall x. Stmt -> Rep Stmt x)
-> (forall x. Rep Stmt x -> Stmt) -> Generic Stmt
forall x. Rep Stmt x -> Stmt
forall x. Stmt -> Rep Stmt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Stmt x -> Stmt
$cfrom :: forall x. Stmt -> Rep Stmt x
Generic, Stmt -> ()
(Stmt -> ()) -> NFData Stmt
forall a. (a -> ()) -> NFData a
rnf :: Stmt -> ()
$crnf :: Stmt -> ()
NFData)

data Exp = ConstInt Int64
         | ConstInt8 Int8
         | ConstTag Word8
         | ConstWord Word
         | ConstBool Bool
         | Reg Temp -- TODO: size?
         | Mem Int64 Exp -- fetch from address
         | ExprIntBinOp IntBinOp Exp Exp
         | ExprIntRel RelBinOp Exp Exp
         | BoolBinOp BoolBinOp Exp Exp
         | IntNegIR Exp
         | PopcountIR Exp
         | EqByte Exp Exp
         deriving ((forall x. Exp -> Rep Exp x)
-> (forall x. Rep Exp x -> Exp) -> Generic Exp
forall x. Rep Exp x -> Exp
forall x. Exp -> Rep Exp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Exp x -> Exp
$cfrom :: forall x. Exp -> Rep Exp x
Generic, Exp -> ()
(Exp -> ()) -> NFData Exp
forall a. (a -> ()) -> NFData a
rnf :: Exp -> ()
$crnf :: Exp -> ()
NFData)
           -- TODO: one for data, one for C ABI

data BoolBinOp = BoolAnd
               | BoolOr
               | BoolXor
               deriving ((forall x. BoolBinOp -> Rep BoolBinOp x)
-> (forall x. Rep BoolBinOp x -> BoolBinOp) -> Generic BoolBinOp
forall x. Rep BoolBinOp x -> BoolBinOp
forall x. BoolBinOp -> Rep BoolBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BoolBinOp x -> BoolBinOp
$cfrom :: forall x. BoolBinOp -> Rep BoolBinOp x
Generic, BoolBinOp -> ()
(BoolBinOp -> ()) -> NFData BoolBinOp
forall a. (a -> ()) -> NFData a
rnf :: BoolBinOp -> ()
$crnf :: BoolBinOp -> ()
NFData)

instance Pretty BoolBinOp where
    pretty :: BoolBinOp -> Doc ann
pretty BoolBinOp
BoolAnd = Doc ann
"&"
    pretty BoolBinOp
BoolOr  = Doc ann
"||"
    pretty BoolBinOp
BoolXor = Doc ann
"xor"

data RelBinOp = IntEqIR
              | IntNeqIR
              | IntLtIR
              | IntGtIR
              | IntLeqIR
              | IntGeqIR
              deriving ((forall x. RelBinOp -> Rep RelBinOp x)
-> (forall x. Rep RelBinOp x -> RelBinOp) -> Generic RelBinOp
forall x. Rep RelBinOp x -> RelBinOp
forall x. RelBinOp -> Rep RelBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelBinOp x -> RelBinOp
$cfrom :: forall x. RelBinOp -> Rep RelBinOp x
Generic, RelBinOp -> ()
(RelBinOp -> ()) -> NFData RelBinOp
forall a. (a -> ()) -> NFData a
rnf :: RelBinOp -> ()
$crnf :: RelBinOp -> ()
NFData)

instance Pretty RelBinOp where
    pretty :: RelBinOp -> Doc ann
pretty RelBinOp
IntEqIR  = Doc ann
"="
    pretty RelBinOp
IntNeqIR = Doc ann
"!="
    pretty RelBinOp
IntLtIR  = Doc ann
"<"
    pretty RelBinOp
IntGtIR  = Doc ann
">"
    pretty RelBinOp
IntLeqIR = Doc ann
"<="
    pretty RelBinOp
IntGeqIR = Doc ann
">="

data IntBinOp = IntPlusIR
              | IntTimesIR
              | IntDivIR
              | IntMinusIR
              | IntModIR -- rem?
              | IntXorIR
              | WordShiftRIR -- compiles to shr on x86
              | WordShiftLIR
              -- int/word mod are different, see: https://stackoverflow.com/questions/8231882/how-to-implement-the-mod-operator-in-assembly
              | WordModIR
              | WordDivIR
              deriving ((forall x. IntBinOp -> Rep IntBinOp x)
-> (forall x. Rep IntBinOp x -> IntBinOp) -> Generic IntBinOp
forall x. Rep IntBinOp x -> IntBinOp
forall x. IntBinOp -> Rep IntBinOp x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IntBinOp x -> IntBinOp
$cfrom :: forall x. IntBinOp -> Rep IntBinOp x
Generic, IntBinOp -> ()
(IntBinOp -> ()) -> NFData IntBinOp
forall a. (a -> ()) -> NFData a
rnf :: IntBinOp -> ()
$crnf :: IntBinOp -> ()
NFData)

instance Pretty IntBinOp where
    pretty :: IntBinOp -> Doc ann
pretty IntBinOp
IntPlusIR    = Doc ann
"+"
    pretty IntBinOp
IntTimesIR   = Doc ann
"*"
    pretty IntBinOp
IntDivIR     = Doc ann
"/"
    pretty IntBinOp
IntMinusIR   = Doc ann
"-"
    pretty IntBinOp
IntModIR     = Doc ann
"%"
    pretty IntBinOp
IntXorIR     = Doc ann
"xor"
    pretty IntBinOp
WordShiftRIR = Doc ann
">>"
    pretty IntBinOp
WordShiftLIR = Doc ann
"<<"
    pretty IntBinOp
WordModIR    = Doc ann
"%~"
    pretty IntBinOp
WordDivIR    = Doc ann
"/~"

writeModule :: Module () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeModule :: Module () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeModule = (KempeDecl () (ConsAnn MonoStackType) MonoStackType
 -> TempM [Stmt])
-> Module () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA KempeDecl () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeDecl

-- optimize tail-recursion, if possible
-- This is a little slow
tryTCO :: Maybe Label -> [Stmt] -> [Stmt]
tryTCO :: Maybe Label -> [Stmt] -> [Stmt]
tryTCO Maybe Label
_ []           = []
tryTCO Maybe Label
Nothing [Stmt]
stmts  = [Stmt]
stmts
tryTCO (Just Label
l) [Stmt]
stmts =
    let end :: Stmt
end = [Stmt] -> Stmt
forall a. [a] -> a
last [Stmt]
stmts
        in
            case Stmt
end of
                KCall Label
l' | Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
l' -> [Stmt] -> [Stmt]
forall a. [a] -> [a]
init [Stmt]
stmts [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Label -> Stmt
Jump Label
l]
                Stmt
_                  -> [Stmt]
stmts

-- FIXME: Current broadcast + write approach fails mutually recursive functions
writeDecl :: KempeDecl () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeDecl :: KempeDecl () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeDecl (FunDecl MonoStackType
_ (Name Text
_ Unique
u MonoStackType
_) [KempeTy ()]
_ [KempeTy ()]
_ [Atom (ConsAnn MonoStackType) MonoStackType]
as) = do
    Label
bl <- Unique -> TempM Label
broadcastName Unique
u
    ([Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
Ret]) ([Stmt] -> [Stmt]) -> ([Stmt] -> [Stmt]) -> [Stmt] -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Stmt
Labeled Label
blStmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
:) ([Stmt] -> [Stmt]) -> ([Stmt] -> [Stmt]) -> [Stmt] -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Label -> [Stmt] -> [Stmt]
tryTCO (Label -> Maybe Label
forall a. a -> Maybe a
Just Label
bl) ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms (Label -> Maybe Label
forall a. a -> Maybe a
Just Label
bl) [Atom (ConsAnn MonoStackType) MonoStackType]
as
writeDecl (ExtFnDecl MonoStackType
ty (Name Text
_ Unique
u MonoStackType
_) [KempeTy ()]
_ [KempeTy ()]
_ ByteString
cName) = do
    Label
bl <- Unique -> TempM Label
broadcastName Unique
u
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Label -> Stmt
Labeled Label
bl, MonoStackType -> ByteString -> Stmt
CCall MonoStackType
ty ByteString
cName, Stmt
Ret] -- TODO: caller-save registers here
writeDecl (Export MonoStackType
sTy ABI
abi Name MonoStackType
n) = Stmt -> [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> [Stmt]) -> (Label -> Stmt) -> Label -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ABI -> MonoStackType -> ByteString -> Label -> Stmt
WrapKCall ABI
abi MonoStackType
sTy (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Name MonoStackType -> Text
forall a. Name a -> Text
name Name MonoStackType
n) (Label -> [Stmt]) -> TempM Label -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name MonoStackType -> TempM Label
forall a. Name a -> TempM Label
lookupName Name MonoStackType
n
writeDecl TyDecl{} = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: type declarations should not exist at this stage"

writeAtoms :: Maybe Label -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms :: Maybe Label
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms Maybe Label
_ [] = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
writeAtoms Maybe Label
Nothing [Atom (ConsAnn MonoStackType) MonoStackType]
stmts = (Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt])
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA (Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
forall a. Maybe a
Nothing) [Atom (ConsAnn MonoStackType) MonoStackType]
stmts
writeAtoms Maybe Label
l [Atom (ConsAnn MonoStackType) MonoStackType]
stmts =
    let end :: Atom (ConsAnn MonoStackType) MonoStackType
end = [Atom (ConsAnn MonoStackType) MonoStackType]
-> Atom (ConsAnn MonoStackType) MonoStackType
forall a. [a] -> a
last [Atom (ConsAnn MonoStackType) MonoStackType]
stmts
        in [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
(++) ([Stmt] -> [Stmt] -> [Stmt])
-> TempM [Stmt] -> StateT TempSt Identity ([Stmt] -> [Stmt])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt])
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA (Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
forall a. Maybe a
Nothing) ([Atom (ConsAnn MonoStackType) MonoStackType]
-> [Atom (ConsAnn MonoStackType) MonoStackType]
forall a. [a] -> [a]
init [Atom (ConsAnn MonoStackType) MonoStackType]
stmts) StateT TempSt Identity ([Stmt] -> [Stmt])
-> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
l Atom (ConsAnn MonoStackType) MonoStackType
end

intShift :: IntBinOp -> TempM [Stmt]
intShift :: IntBinOp -> TempM [Stmt]
intShift IntBinOp
cons = do
    Temp
t0 <- TempM Temp
getTemp8
    Temp
t1 <- TempM Temp
getTemp64
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
1 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t1 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
8 (IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
cons (Temp -> Exp
Reg Temp
t1) (Temp -> Exp
Reg Temp
t0))

boolOp :: BoolBinOp -> TempM [Stmt]
boolOp :: BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
op = do
    Temp
t0 <- TempM Temp
getTemp8
    Temp
t1 <- TempM Temp
getTemp8
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
1 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Temp -> [Stmt]
pop Int64
1 Temp
t1 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
1 (BoolBinOp -> Exp -> Exp -> Exp
BoolBinOp BoolBinOp
op (Temp -> Exp
Reg Temp
t1) (Temp -> Exp
Reg Temp
t0))

intOp :: IntBinOp -> TempM [Stmt]
intOp :: IntBinOp -> TempM [Stmt]
intOp IntBinOp
cons = do
    Temp
t0 <- TempM Temp
getTemp64 -- registers are 64 bits for integers
    Temp
t1 <- TempM Temp
getTemp64
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t1 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
8 (IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
cons (Temp -> Exp
Reg Temp
t1) (Temp -> Exp
Reg Temp
t0))

-- | Push bytes onto the Kempe data pointer
push :: Int64 -> Exp -> [Stmt]
push :: Int64 -> Exp -> [Stmt]
push Int64
off Exp
e =
    [ Exp -> Int64 -> Exp -> Stmt
MovMem (Temp -> Exp
Reg Temp
DataPointer) Int64
off Exp
e
    , Int64 -> Stmt
dataPointerInc Int64
off -- increment instead of decrement b/c this is the Kempe ABI
    ]

pop :: Int64 -> Temp -> [Stmt]
pop :: Int64 -> Temp -> [Stmt]
pop Int64
sz Temp
t =
    [ Int64 -> Stmt
dataPointerDec Int64
sz
    , Temp -> Exp -> Stmt
MovTemp Temp
t (Int64 -> Exp -> Exp
Mem Int64
sz (Temp -> Exp
Reg Temp
DataPointer))
    ]

-- FIXME: just use expressions from memory accesses
intRel :: RelBinOp -> TempM [Stmt]
intRel :: RelBinOp -> TempM [Stmt]
intRel RelBinOp
cons = do
    Temp
t0 <- TempM Temp
getTemp64
    Temp
t1 <- TempM Temp
getTemp64
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t1 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
1 (RelBinOp -> Exp -> Exp -> Exp
ExprIntRel RelBinOp
cons (Temp -> Exp
Reg Temp
t1) (Temp -> Exp
Reg Temp
t0))

intNeg :: TempM [Stmt]
intNeg :: TempM [Stmt]
intNeg = do
    Temp
t0 <- TempM Temp
getTemp64
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
8 (Exp -> Exp
IntNegIR (Temp -> Exp
Reg Temp
t0))

wordCount :: TempM [Stmt]
wordCount :: TempM [Stmt]
wordCount = do
    Temp
t0 <- TempM Temp
getTemp64
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Temp -> [Stmt]
pop Int64
8 Temp
t0 [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
8 (Exp -> Exp
PopcountIR (Temp -> Exp
Reg Temp
t0))

-- | This throws exceptions on nonsensical input.
writeAtom :: Maybe Label -- ^ Context for possible TCO
          -> Atom (ConsAnn MonoStackType) MonoStackType
          -> TempM [Stmt]
writeAtom :: Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
_ (IntLit MonoStackType
_ Integer
i)              = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp -> [Stmt]
push Int64
8 (Int64 -> Exp
ConstInt (Int64 -> Exp) -> Int64 -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i)
writeAtom Maybe Label
_ (Int8Lit MonoStackType
_ Int8
i)             = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp -> [Stmt]
push Int64
1 (Int8 -> Exp
ConstInt8 Int8
i)
writeAtom Maybe Label
_ (WordLit MonoStackType
_ Natural
w)             = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp -> [Stmt]
push Int64
8 (Label -> Exp
ConstWord (Label -> Exp) -> Label -> Exp
forall a b. (a -> b) -> a -> b
$ Natural -> Label
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
w)
writeAtom Maybe Label
_ (BoolLit MonoStackType
_ Bool
b)             = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp -> [Stmt]
push Int64
1 (Bool -> Exp
ConstBool Bool
b)
writeAtom Maybe Label
_ (AtName MonoStackType
_ Name MonoStackType
n)              = Stmt -> [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> [Stmt]) -> (Label -> Stmt) -> Label -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Stmt
KCall (Label -> [Stmt]) -> TempM Label -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name MonoStackType -> TempM Label
forall a. Name a -> TempM Label
lookupName Name MonoStackType
n
writeAtom Maybe Label
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Drop)  = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed drop!"
writeAtom Maybe Label
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Dup)   = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dup!"
writeAtom Maybe Label
_ (Dip ([], [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
_)           = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dip()!"
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntPlus)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntPlusIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntMinus)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntMinusIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntTimes)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntTimesIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntDiv)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntDivIR -- what to do on failure?
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntMod)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntModIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntXor)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntXorIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftR)   = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftRIR -- TODO: shr or sar?
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftL)   = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftLIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntEq)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntEqIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntLt)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntLtIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntLeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntLeqIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordPlus)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntPlusIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordTimes)   = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntTimesIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordXor)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntXorIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordMinus)   = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntMinusIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntNeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntNeqIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntGeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntGeqIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntGt)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntGtIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftL)  = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftLIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftR)  = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftRIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordDiv)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
WordDivIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordMod)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
WordModIR
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
And)         = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolAnd
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
Or)          = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolOr
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
Xor)         = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolXor
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntNeg)      = TempM [Stmt]
intNeg
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
Popcount)    = TempM [Stmt]
wordCount
writeAtom Maybe Label
_ (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Drop)  =
    let sz :: Int64
sz = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is) in
        [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Int64 -> Stmt
dataPointerDec Int64
sz ]
writeAtom Maybe Label
_ (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Dup)   =
    let sz :: Int64
sz = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is) in
        [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
             Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz) Int64
sz
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [ Int64 -> Stmt
dataPointerInc Int64
sz ] -- move data pointer over sz bytes
writeAtom Maybe Label
l (If MonoStackType
_ [Atom (ConsAnn MonoStackType) MonoStackType]
as [Atom (ConsAnn MonoStackType) MonoStackType]
as') = do
    Label
l0 <- TempM Label
newLabel
    Label
l1 <- TempM Label
newLabel
    let ifIR :: Stmt
ifIR = Exp -> Label -> Label -> Stmt
CJump (Int64 -> Exp -> Exp
Mem Int64
1 (Temp -> Exp
Reg Temp
DataPointer)) Label
l0 Label
l1
    [Stmt]
asIR <- Maybe Label -> [Stmt] -> [Stmt]
tryTCO Maybe Label
l ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms Maybe Label
l [Atom (ConsAnn MonoStackType) MonoStackType]
as
    [Stmt]
asIR' <- Maybe Label -> [Stmt] -> [Stmt]
tryTCO Maybe Label
l ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms Maybe Label
l [Atom (ConsAnn MonoStackType) MonoStackType]
as'
    Label
l2 <- TempM Label
newLabel
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Stmt
dataPointerDec Int64
1 Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: Stmt
ifIR Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: (Label -> Stmt
Labeled Label
l0 Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
asIR [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Label -> Stmt
Jump Label
l2]) [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ (Label -> Stmt
Labeled Label
l1 Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
asIR') [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Label -> Stmt
Labeled Label
l2]
writeAtom Maybe Label
_ (Dip ([KempeTy ()]
is, [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
as) =
    let sz :: Int64
sz = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is)
    in (Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt])
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA (Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
dipify Int64
sz) [Atom (ConsAnn MonoStackType) MonoStackType]
as
writeAtom Maybe Label
_ (AtBuiltin ([KempeTy ()
i0, KempeTy ()
i1], [KempeTy ()]
_) BuiltinFn
Swap) =
    let sz0 :: Int64
sz0 = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size KempeTy ()
i0
        sz1 :: Int64
sz1 = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size KempeTy ()
i1
    in
        [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
            Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz1) Int64
sz0 -- copy i0 to end of the stack
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz1) (-Int64
sz1) Int64
sz1 -- copy i1 to where i0 used to be
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz0) Int64
0 Int64
sz0 -- copy i0 at end of stack to its new place
writeAtom Maybe Label
_ (AtBuiltin MonoStackType
_ BuiltinFn
Swap) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Ill-typed swap!"
writeAtom Maybe Label
_ (AtCons ann :: ConsAnn MonoStackType
ann@(ConsAnn Int64
_ Word8
tag' MonoStackType
_) TyName (ConsAnn MonoStackType)
_) =
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Stmt
dataPointerInc (ConsAnn MonoStackType -> Int64
padBytes ConsAnn MonoStackType
ann) Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: Int64 -> Exp -> [Stmt]
push Int64
1 (Word8 -> Exp
ConstTag Word8
tag')
writeAtom Maybe Label
_ (Case ([], [KempeTy ()]
_) NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
_) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed case statement?!"
writeAtom Maybe Label
l (Case ([KempeTy ()]
is, [KempeTy ()]
_) NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
ls) =
    let (NonEmpty (Pattern (ConsAnn MonoStackType) MonoStackType)
ps, NonEmpty [Atom (ConsAnn MonoStackType) MonoStackType]
ass) = NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
-> (NonEmpty (Pattern (ConsAnn MonoStackType) MonoStackType),
    NonEmpty [Atom (ConsAnn MonoStackType) MonoStackType])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
ls
        decSz :: Int64
decSz = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is)
        in do
            NonEmpty ([Stmt], [Stmt])
leaves <- (Pattern (ConsAnn MonoStackType) MonoStackType
 -> [Atom (ConsAnn MonoStackType) MonoStackType]
 -> StateT TempSt Identity ([Stmt], [Stmt]))
-> NonEmpty (Pattern (ConsAnn MonoStackType) MonoStackType)
-> NonEmpty [Atom (ConsAnn MonoStackType) MonoStackType]
-> StateT TempSt Identity (NonEmpty ([Stmt], [Stmt]))
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)
zipWithM (Maybe Label
-> Pattern (ConsAnn MonoStackType) MonoStackType
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> StateT TempSt Identity ([Stmt], [Stmt])
mkLeaf Maybe Label
l) NonEmpty (Pattern (ConsAnn MonoStackType) MonoStackType)
ps NonEmpty [Atom (ConsAnn MonoStackType) MonoStackType]
ass
            let (NonEmpty [Stmt]
switches, NonEmpty [Stmt]
meat) = NonEmpty ([Stmt], [Stmt]) -> (NonEmpty [Stmt], NonEmpty [Stmt])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip NonEmpty ([Stmt], [Stmt])
leaves
            Label
ret <- TempM Label
newLabel
            let meat' :: NonEmpty [Stmt]
meat' = ([Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Label -> Stmt
Jump Label
ret]) ([Stmt] -> [Stmt]) -> ([Stmt] -> [Stmt]) -> [Stmt] -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Stmt] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Stmt] -> [Stmt]) -> NonEmpty [Stmt] -> NonEmpty [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty [Stmt]
meat
            [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Stmt
dataPointerDec Int64
decSz Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: ([Stmt] -> [Stmt]) -> NonEmpty [Stmt] -> [Stmt]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Stmt] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty [Stmt]
switches [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ NonEmpty [Stmt] -> [Stmt]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat NonEmpty [Stmt]
meat' [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Label -> Stmt
Labeled Label
ret]

zipWithM :: (Applicative m) => (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)
zipWithM :: (a -> b -> m c) -> NonEmpty a -> NonEmpty b -> m (NonEmpty c)
zipWithM a -> b -> m c
f NonEmpty a
xs NonEmpty b
ys = NonEmpty (m c) -> m (NonEmpty c)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ((a -> b -> m c) -> NonEmpty a -> NonEmpty b -> NonEmpty (m c)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NE.zipWith a -> b -> m c
f NonEmpty a
xs NonEmpty b
ys)

mkLeaf :: Maybe Label -> Pattern (ConsAnn MonoStackType) MonoStackType -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM ([Stmt], [Stmt])
mkLeaf :: Maybe Label
-> Pattern (ConsAnn MonoStackType) MonoStackType
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> StateT TempSt Identity ([Stmt], [Stmt])
mkLeaf Maybe Label
l Pattern (ConsAnn MonoStackType) MonoStackType
p [Atom (ConsAnn MonoStackType) MonoStackType]
as = do
    Label
l' <- TempM Label
newLabel
    [Stmt]
as' <- Maybe Label
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms Maybe Label
l [Atom (ConsAnn MonoStackType) MonoStackType]
as
    let s :: [Stmt]
s = Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch Pattern (ConsAnn MonoStackType) MonoStackType
p Label
l'
    ([Stmt], [Stmt]) -> StateT TempSt Identity ([Stmt], [Stmt])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt]
s, Label -> Stmt
Labeled Label
l' Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
as')

patternSwitch :: Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch :: Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch (PatternBool MonoStackType
_ Bool
True) Label
l                   = [Exp -> Label -> Stmt
MJump (Int64 -> Exp -> Exp
Mem Int64
1 (Temp -> Exp
Reg Temp
DataPointer)) Label
l]
patternSwitch (PatternBool MonoStackType
_ Bool
False) Label
l                  = [Exp -> Label -> Stmt
MJump (Exp -> Exp -> Exp
EqByte (Int64 -> Exp -> Exp
Mem Int64
1 (Temp -> Exp
Reg Temp
DataPointer)) (Word8 -> Exp
ConstTag Word8
0)) Label
l]
patternSwitch (PatternWildcard MonoStackType
_) Label
l                    = [Label -> Stmt
Jump Label
l]
patternSwitch (PatternInt MonoStackType
_ Integer
i) Label
l                       = [Exp -> Label -> Stmt
MJump (RelBinOp -> Exp -> Exp -> Exp
ExprIntRel RelBinOp
IntEqIR (Int64 -> Exp -> Exp
Mem Int64
8 (Temp -> Exp
Reg Temp
DataPointer)) (Int64 -> Exp
ConstInt (Int64 -> Exp) -> Int64 -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i)) Label
l]
patternSwitch (PatternCons ann :: ConsAnn MonoStackType
ann@(ConsAnn Int64
_ Word8
tag' MonoStackType
_) TyName (ConsAnn MonoStackType)
_) Label
l =
    let padAt :: Int64
padAt = ConsAnn MonoStackType -> Int64
padBytes ConsAnn MonoStackType
ann Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1
        -- decrement by padAt bytes (to discard padding), then we need to access
        -- the tag at [datapointer+padAt] when we check
        in [ Int64 -> Stmt
dataPointerDec Int64
padAt, Exp -> Label -> Stmt
MJump (Exp -> Exp -> Exp
EqByte (Int64 -> Exp -> Exp
Mem Int64
1 (IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
IntPlusIR (Temp -> Exp
Reg Temp
DataPointer) (Int64 -> Exp
ConstInt Int64
padAt))) (Word8 -> Exp
ConstTag Word8
tag')) Label
l]

-- | Constructors may need to be padded, this computes the number of bytes of
-- padding
padBytes :: ConsAnn MonoStackType -> Int64
padBytes :: ConsAnn MonoStackType -> Int64
padBytes (ConsAnn Int64
sz Word8
_ ([KempeTy ()]
is, [KempeTy ()]
_)) = Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- [KempeTy ()] -> Int64
forall a. [KempeTy a] -> Int64
sizeStack [KempeTy ()]
is Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1

dipify :: Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
dipify :: Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
dipify Int64
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Drop) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed drop!"
dipify Int64
sz (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Drop) =
    let sz' :: Int64
sz' = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is)
        shift :: Stmt
shift = Int64 -> Stmt
dataPointerDec Int64
sz' -- shift data pointer over by sz' bytes
        -- copy sz bytes over (-sz') bytes from the data pointer
        copyBytes' :: [Stmt]
copyBytes' = Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz') (-Int64
sz) Int64
sz
        in [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ [Stmt]
copyBytes' [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
shift]
dipify Int64
sz (AtBuiltin ([KempeTy ()
i0, KempeTy ()
i1], [KempeTy ()]
_) BuiltinFn
Swap) =
    let sz0 :: Int64
sz0 = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size KempeTy ()
i0
        sz1 :: Int64
sz1 = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size KempeTy ()
i1
    in
        [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
            Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz1) Int64
sz0 -- copy i0 to end of the stack
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz0 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz1) (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz1) Int64
sz1 -- copy i1 to where i0 used to be
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz0) Int64
0 Int64
sz0 -- copy i0 at end of stack to its new place
dipify Int64
_ (Dip ([], [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
_) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dip()!"
dipify Int64
sz (Dip ([KempeTy ()]
is, [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
as) =
    let sz' :: Int64
sz' = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is)
        in (Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt])
-> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA (Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
dipify (Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
sz')) [Atom (ConsAnn MonoStackType) MonoStackType]
as
dipify Int64
_ (AtBuiltin MonoStackType
_ BuiltinFn
Swap)        = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed swap!"
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntTimes)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntTimesIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntPlus)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntPlusIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntMinus)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntMinusIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntDiv)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntDivIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntMod)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntModIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntXor)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntXorIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntEq)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntEqIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntLt)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntLtIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntLeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntLeqIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftL)  = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftLIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftR)  = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftRIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordXor)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntXorIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftL) = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftLIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftR) = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftRIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordPlus)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntPlusIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordTimes)  = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntTimesIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntGeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntGeqIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntGt)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntGtIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntNeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntNeqIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntNeg)     = Int64 -> [Stmt] -> [Stmt]
plainShift Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TempM [Stmt]
intNeg
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
Popcount)   = Int64 -> [Stmt] -> [Stmt]
plainShift Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TempM [Stmt]
wordCount
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
And)        = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolAnd
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
Or)         = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolOr
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
Xor)        = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolXor
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordMinus)  = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntMinusIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordDiv)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
WordDivIR
dipify Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordMod)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
WordModIR
dipify Int64
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Dup) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dup!"
dipify Int64
sz (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Dup) = do
    let sz' :: Int64
sz' = KempeTy () -> Int64
forall a. KempeTy a -> Int64
size ([KempeTy ()] -> KempeTy ()
forall a. [a] -> a
last [KempeTy ()]
is) in
        [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
             Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz) Int64
sz -- copy sz bytes over to the end of the stack
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz) (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sz') Int64
sz' -- copy sz' bytes over (duplicate)
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
sz') Int64
0 Int64
sz -- copy sz bytes back
                [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [ Int64 -> Stmt
dataPointerInc Int64
sz' ] -- move data pointer over sz' bytes
dipify Int64
sz (IntLit MonoStackType
_ Integer
i) = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
8 (Int64 -> Exp
ConstInt (Int64 -> Exp) -> Int64 -> Exp
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i)
dipify Int64
sz (WordLit MonoStackType
_ Natural
w) = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
8 (Label -> Exp
ConstWord (Label -> Exp) -> Label -> Exp
forall a b. (a -> b) -> a -> b
$ Natural -> Label
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
w)
dipify Int64
sz (Int8Lit MonoStackType
_ Int8
i) = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
1 (Int8 -> Exp
ConstInt8 Int8
i)
dipify Int64
sz (BoolLit MonoStackType
_ Bool
b) = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
1 (Bool -> Exp
ConstBool Bool
b)
dipify Int64
sz (AtCons ann :: ConsAnn MonoStackType
ann@(ConsAnn Int64
_ Word8
tag' MonoStackType
_) TyName (ConsAnn MonoStackType)
_) =
    [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Stmt] -> TempM [Stmt]) -> [Stmt] -> TempM [Stmt]
forall a b. (a -> b) -> a -> b
$
        Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz) Int64
sz
            [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Stmt
dataPointerInc (ConsAnn MonoStackType -> Int64
padBytes ConsAnn MonoStackType
ann) Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: Int64 -> Exp -> [Stmt]
push Int64
1 (Word8 -> Exp
ConstTag Word8
tag')
            [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz) Int64
0 Int64
sz
dipify Int64
sz a :: Atom (ConsAnn MonoStackType) MonoStackType
a@(If MonoStackType
sty [Atom (ConsAnn MonoStackType) MonoStackType]
_ [Atom (ConsAnn MonoStackType) MonoStackType]
_) =
    Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp Int64
sz MonoStackType
sty ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
forall a. Maybe a
Nothing Atom (ConsAnn MonoStackType) MonoStackType
a
dipify Int64
sz (AtName MonoStackType
sty Name MonoStackType
n) =
    Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp Int64
sz MonoStackType
sty ([Stmt] -> [Stmt]) -> (Label -> [Stmt]) -> Label -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stmt -> [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stmt -> [Stmt]) -> (Label -> Stmt) -> Label -> [Stmt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Stmt
KCall (Label -> [Stmt]) -> TempM Label -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name MonoStackType -> TempM Label
forall a. Name a -> TempM Label
lookupName Name MonoStackType
n
dipify Int64
sz a :: Atom (ConsAnn MonoStackType) MonoStackType
a@(Case MonoStackType
sty NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
_) =
    Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp Int64
sz MonoStackType
sty ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Label
-> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeAtom Maybe Label
forall a. Maybe a
Nothing Atom (ConsAnn MonoStackType) MonoStackType
a

dipSupp :: Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp :: Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp Int64
sz ([KempeTy ()]
is, [KempeTy ()]
os) [Stmt]
stmts =
    let excessSz :: Int64
excessSz = [KempeTy ()] -> Int64
forall a. [KempeTy a] -> Int64
sizeStack [KempeTy ()]
os Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- [KempeTy ()] -> Int64
forall a. [KempeTy a] -> Int64
sizeStack [KempeTy ()]
is -- how much the atom(s) grow the stack
        in case Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int64
excessSz Int64
0 of
            Ordering
EQ -> Int64 -> [Stmt] -> [Stmt]
plainShift Int64
sz [Stmt]
stmts
            Ordering
LT -> Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz [Stmt]
stmts

dipPush :: Int64 -> Int64 -> Exp -> [Stmt]
dipPush :: Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
sz' Exp
e =
    Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 (-Int64
sz) Int64
sz
        [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Exp -> [Stmt]
push Int64
sz' Exp
e
        [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
sz) Int64
0 Int64
sz -- copy bytes back (data pointer has been incremented already by push)

-- for e.g. negation where the stack size stays the same
plainShift :: Int64 -> [Stmt] -> [Stmt]
plainShift :: Int64 -> [Stmt] -> [Stmt]
plainShift Int64
sz [Stmt]
stmt =
    let shiftNext :: Stmt
shiftNext = Int64 -> Stmt
dataPointerDec Int64
sz
        shiftBack :: Stmt
shiftBack = Int64 -> Stmt
dataPointerInc Int64
sz
    in
        (Stmt
shiftNext Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmt [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
shiftBack])

-- works in general because relations, shifts, operations shrink the size of the
-- stack.
dipDo :: Int64 -> [Stmt] -> [Stmt]
dipDo :: Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz [Stmt]
stmt =
    let shiftNext :: Stmt
shiftNext = Int64 -> Stmt
dataPointerDec Int64
sz
        shiftBack :: Stmt
shiftBack = Int64 -> Stmt
dataPointerInc Int64
sz
        copyBytes' :: [Stmt]
copyBytes' = Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
0 Int64
sz Int64
sz
    in
        (Stmt
shiftNext Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: [Stmt]
stmt [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
copyBytes' [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
shiftBack])

dipShift :: Int64 -> IntBinOp -> TempM [Stmt]
dipShift :: Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
op = Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntBinOp -> TempM [Stmt]
intShift IntBinOp
op

dipRel :: Int64 -> RelBinOp -> TempM [Stmt]
dipRel :: Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
rel = Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RelBinOp -> TempM [Stmt]
intRel RelBinOp
rel

dipOp :: Int64 -> IntBinOp -> TempM [Stmt]
dipOp :: Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
op = Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntBinOp -> TempM [Stmt]
intOp IntBinOp
op

dipBoolOp :: Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp :: Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
op = Int64 -> [Stmt] -> [Stmt]
dipDo Int64
sz ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
op

copyBytes :: Int64 -- ^ dest offset
          -> Int64 -- ^ src offset
          -> Int64 -- ^ Number of bytes to copy
          -> [Stmt]
copyBytes :: Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
off1 Int64
off2 Int64
b
    | Int64
b Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`mod` Int64
8 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0 =
        let is :: [Int64]
is = (Int64 -> Int64) -> [Int64] -> [Int64]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int64
8Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
*) [Int64
0..(Int64
b Int64 -> Int64 -> Int64
forall a. Integral a => a -> a -> a
`div` Int64
8 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1)] in
            [ Exp -> Int64 -> Exp -> Stmt
MovMem (Int64 -> Exp
dataPointerPlus (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
off1)) Int64
8 (Int64 -> Exp -> Exp
Mem Int64
8 (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp
dataPointerPlus (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
off2)) | Int64
i <- [Int64]
is ]
    | Bool
otherwise =
        [ Exp -> Int64 -> Exp -> Stmt
MovMem (Int64 -> Exp
dataPointerPlus (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
off1)) Int64
1 (Int64 -> Exp -> Exp
Mem Int64
1 (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Int64 -> Exp
dataPointerPlus (Int64
i Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
off2)) | Int64
i <- [Int64
0..(Int64
bInt64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
-Int64
1)] ]

dataPointerDec :: Int64 -> Stmt
dataPointerDec :: Int64 -> Stmt
dataPointerDec Int64
i = Temp -> Exp -> Stmt
MovTemp Temp
DataPointer (IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
IntMinusIR (Temp -> Exp
Reg Temp
DataPointer) (Int64 -> Exp
ConstInt Int64
i))

dataPointerInc :: Int64 -> Stmt
dataPointerInc :: Int64 -> Stmt
dataPointerInc Int64
i = Temp -> Exp -> Stmt
MovTemp Temp
DataPointer (IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
IntPlusIR (Temp -> Exp
Reg Temp
DataPointer) (Int64 -> Exp
ConstInt Int64
i))

dataPointerPlus :: Int64 -> Exp
dataPointerPlus :: Int64 -> Exp
dataPointerPlus Int64
off =
    if Int64
off Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
0
        then IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
IntPlusIR (Temp -> Exp
Reg Temp
DataPointer) (Int64 -> Exp
ConstInt Int64
off)
        else IntBinOp -> Exp -> Exp -> Exp
ExprIntBinOp IntBinOp
IntMinusIR (Temp -> Exp
Reg Temp
DataPointer) (Int64 -> Exp
ConstInt (Int64 -> Int64
forall a. Num a => a -> a
negate Int64
off))