{-# 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, traverse_)
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.Semigroup             ((<>))
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, 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 ()
broadcastName :: Unique -> StateT TempSt Identity ()
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)

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
forall ann. [Doc ann] -> Doc ann
prettyLines ([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 (Exp -> Exp -> Bool
(Exp -> Exp -> Bool) -> (Exp -> Exp -> Bool) -> Eq Exp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Exp -> Exp -> Bool
$c/= :: Exp -> Exp -> Bool
== :: Exp -> Exp -> Bool
$c== :: Exp -> Exp -> Bool
Eq, (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 (BoolBinOp -> BoolBinOp -> Bool
(BoolBinOp -> BoolBinOp -> Bool)
-> (BoolBinOp -> BoolBinOp -> Bool) -> Eq BoolBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BoolBinOp -> BoolBinOp -> Bool
$c/= :: BoolBinOp -> BoolBinOp -> Bool
== :: BoolBinOp -> BoolBinOp -> Bool
$c== :: BoolBinOp -> BoolBinOp -> Bool
Eq, (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 (RelBinOp -> RelBinOp -> Bool
(RelBinOp -> RelBinOp -> Bool)
-> (RelBinOp -> RelBinOp -> Bool) -> Eq RelBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelBinOp -> RelBinOp -> Bool
$c/= :: RelBinOp -> RelBinOp -> Bool
== :: RelBinOp -> RelBinOp -> Bool
$c== :: RelBinOp -> RelBinOp -> Bool
Eq, (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 (IntBinOp -> IntBinOp -> Bool
(IntBinOp -> IntBinOp -> Bool)
-> (IntBinOp -> IntBinOp -> Bool) -> Eq IntBinOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntBinOp -> IntBinOp -> Bool
$c/= :: IntBinOp -> IntBinOp -> Bool
== :: IntBinOp -> IntBinOp -> Bool
$c== :: IntBinOp -> IntBinOp -> Bool
Eq, (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 :: SizeEnv -> Declarations () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeModule :: SizeEnv
-> Declarations () (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeModule SizeEnv
env Declarations () (ConsAnn MonoStackType) MonoStackType
m = (KempeDecl () (ConsAnn MonoStackType) MonoStackType
 -> StateT TempSt Identity ())
-> Declarations () (ConsAnn MonoStackType) MonoStackType
-> StateT TempSt Identity ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ KempeDecl () (ConsAnn MonoStackType) MonoStackType
-> StateT TempSt Identity ()
forall a c b. KempeDecl a c b -> StateT TempSt Identity ()
assignName Declarations () (ConsAnn MonoStackType) MonoStackType
m StateT TempSt Identity () -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (KempeDecl () (ConsAnn MonoStackType) MonoStackType
 -> TempM [Stmt])
-> Declarations () (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
forall (f :: * -> *) (t :: * -> *) m a.
(Applicative f, Traversable t, Monoid m) =>
(a -> f m) -> t a -> f m
foldMapA (SizeEnv
-> KempeDecl () (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeDecl SizeEnv
env) Declarations () (ConsAnn MonoStackType) MonoStackType
m

-- optimize tail-recursion, if possible
-- This is a little slow
tryTCO :: Bool -- ^ Can it be optimized here?
       -> [Stmt]
       -> [Stmt]
tryTCO :: Bool -> [Stmt] -> [Stmt]
tryTCO Bool
_ []           = []
tryTCO Bool
False [Stmt]
stmts  = [Stmt]
stmts
tryTCO Bool
True [Stmt]
stmts =
    let end :: Stmt
end = [Stmt] -> Stmt
forall a. [a] -> a
last [Stmt]
stmts
        in
            case Stmt
end of
                KCall 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

assignName :: KempeDecl a c b -> TempM ()
assignName :: KempeDecl a c b -> StateT TempSt Identity ()
assignName (FunDecl b
_ (Name Text
_ Unique
u b
_) [KempeTy a]
_ [KempeTy a]
_ [Atom c b]
_)   = Unique -> StateT TempSt Identity ()
broadcastName Unique
u
assignName (ExtFnDecl b
_ (Name Text
_ Unique
u b
_) [KempeTy a]
_ [KempeTy a]
_ ByteString
_) = Unique -> StateT TempSt Identity ()
broadcastName Unique
u
assignName Export{}                         = () -> StateT TempSt Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
assignName TyDecl{}                         = [Char] -> StateT TempSt Identity ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: type declarations should not exist at this stage"


-- FIXME: Current broadcast + write approach fails mutually recursive functions
writeDecl :: SizeEnv -> KempeDecl () (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
writeDecl :: SizeEnv
-> KempeDecl () (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeDecl SizeEnv
env (FunDecl MonoStackType
_ Name MonoStackType
n [KempeTy ()]
_ [KempeTy ()]
_ [Atom (ConsAnn MonoStackType) MonoStackType]
as) = do
    Label
bl <- Name MonoStackType -> TempM Label
forall a. Name a -> TempM Label
lookupName Name MonoStackType
n
    ([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
. Bool -> [Stmt] -> [Stmt]
tryTCO Bool
True ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> Bool
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> TempM [Stmt]
writeAtoms SizeEnv
env Bool
True [Atom (ConsAnn MonoStackType) MonoStackType]
as
writeDecl SizeEnv
_ (ExtFnDecl MonoStackType
ty Name MonoStackType
n [KempeTy ()]
_ [KempeTy ()]
_ ByteString
cName) = do
    Label
bl <- Name MonoStackType -> TempM Label
forall a. Name a -> TempM Label
lookupName Name MonoStackType
n
    [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]
writeDecl SizeEnv
_ (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 SizeEnv
_ TyDecl{} = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: type declarations should not exist at this stage"

writeAtoms :: SizeEnv -> Bool -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM [Stmt]
writeAtoms :: SizeEnv
-> Bool
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> TempM [Stmt]
writeAtoms SizeEnv
_ Bool
_ [] = [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
writeAtoms SizeEnv
env Bool
False [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 (SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
env Bool
False) [Atom (ConsAnn MonoStackType) MonoStackType]
stmts
writeAtoms SizeEnv
env Bool
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 (SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
env Bool
False) ([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
<*> SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
env Bool
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 :: SizeEnv
          -> Bool -- ^ Can we do TCO?
          -> Atom (ConsAnn MonoStackType) MonoStackType
          -> TempM [Stmt]
writeAtom :: SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
_ Bool
_ (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 SizeEnv
_ Bool
_ (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 SizeEnv
_ Bool
_ (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 SizeEnv
_ Bool
_ (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 SizeEnv
_ Bool
_ (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 SizeEnv
_ Bool
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Drop)  = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed drop!"
writeAtom SizeEnv
_ Bool
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Dup)   = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dup!"
writeAtom SizeEnv
_ Bool
_ (Dip ([], [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
_)           = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dip()!"
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntPlus)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntPlusIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntMinus)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntMinusIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntTimes)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntTimesIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntDiv)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntDivIR -- what to do on failure?
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntMod)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntModIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntXor)      = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntXorIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftR)   = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftRIR -- TODO: shr or sar?
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftL)   = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftLIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntEq)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntEqIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntLt)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntLtIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntLeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntLeqIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordPlus)    = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntPlusIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordTimes)   = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntTimesIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordXor)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntXorIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordMinus)   = IntBinOp -> TempM [Stmt]
intOp IntBinOp
IntMinusIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntNeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntNeqIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntGeq)      = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntGeqIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntGt)       = RelBinOp -> TempM [Stmt]
intRel RelBinOp
IntGtIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftL)  = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftLIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftR)  = IntBinOp -> TempM [Stmt]
intShift IntBinOp
WordShiftRIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordDiv)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
WordDivIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
WordMod)     = IntBinOp -> TempM [Stmt]
intOp IntBinOp
WordModIR
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
And)         = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolAnd
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
Or)          = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolOr
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
Xor)         = BoolBinOp -> TempM [Stmt]
boolOp BoolBinOp
BoolXor
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
IntNeg)      = TempM [Stmt]
intNeg
writeAtom SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
Popcount)    = TempM [Stmt]
wordCount
writeAtom SizeEnv
env Bool
_ (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Drop)  =
    let sz :: Int64
sz = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 SizeEnv
env Bool
_ (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Dup)   =
    let sz :: Int64
sz = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 SizeEnv
env Bool
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 <- Bool -> [Stmt] -> [Stmt]
tryTCO Bool
l ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> Bool
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> TempM [Stmt]
writeAtoms SizeEnv
env Bool
l [Atom (ConsAnn MonoStackType) MonoStackType]
as
    [Stmt]
asIR' <- Bool -> [Stmt] -> [Stmt]
tryTCO Bool
l ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> Bool
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> TempM [Stmt]
writeAtoms SizeEnv
env Bool
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 SizeEnv
env Bool
_ (Dip ([KempeTy ()]
is, [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
as) =
    let sz :: Int64
sz = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 (SizeEnv
-> Int64
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
dipify SizeEnv
env Int64
sz) [Atom (ConsAnn MonoStackType) MonoStackType]
as
writeAtom SizeEnv
env Bool
_ (AtBuiltin ([KempeTy ()
i0, KempeTy ()
i1], [KempeTy ()]
_) BuiltinFn
Swap) =
    let sz0 :: Int64
sz0 = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env KempeTy ()
i0
        sz1 :: Int64
sz1 = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env 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 SizeEnv
_ Bool
_ (AtBuiltin MonoStackType
_ BuiltinFn
Swap) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Ill-typed swap!"
writeAtom SizeEnv
env Bool
_ (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 (SizeEnv -> ConsAnn MonoStackType -> Int64
padBytes SizeEnv
env ConsAnn MonoStackType
ann) Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: Int64 -> Exp -> [Stmt]
push Int64
1 (Word8 -> Exp
ConstTag Word8
tag')
writeAtom SizeEnv
_ Bool
_ (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 SizeEnv
env Bool
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 = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 (SizeEnv
-> Bool
-> Pattern (ConsAnn MonoStackType) MonoStackType
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> StateT TempSt Identity ([Stmt], [Stmt])
mkLeaf SizeEnv
env Bool
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 :: SizeEnv -> Bool -> Pattern (ConsAnn MonoStackType) MonoStackType -> [Atom (ConsAnn MonoStackType) MonoStackType] -> TempM ([Stmt], [Stmt])
mkLeaf :: SizeEnv
-> Bool
-> Pattern (ConsAnn MonoStackType) MonoStackType
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> StateT TempSt Identity ([Stmt], [Stmt])
mkLeaf SizeEnv
env Bool
l Pattern (ConsAnn MonoStackType) MonoStackType
p [Atom (ConsAnn MonoStackType) MonoStackType]
as = do
    Label
l' <- TempM Label
newLabel
    [Stmt]
as' <- SizeEnv
-> Bool
-> [Atom (ConsAnn MonoStackType) MonoStackType]
-> TempM [Stmt]
writeAtoms SizeEnv
env Bool
l [Atom (ConsAnn MonoStackType) MonoStackType]
as
    let s :: [Stmt]
s = SizeEnv
-> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch SizeEnv
env 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 :: SizeEnv -> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch :: SizeEnv
-> Pattern (ConsAnn MonoStackType) MonoStackType -> Label -> [Stmt]
patternSwitch SizeEnv
_ (PatternBool MonoStackType
_ Bool
True) Label
l                   = [Exp -> Label -> Stmt
MJump (Int64 -> Exp -> Exp
Mem Int64
1 (Temp -> Exp
Reg Temp
DataPointer)) Label
l]
patternSwitch SizeEnv
_ (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 SizeEnv
_ (PatternWildcard MonoStackType
_) Label
l                    = [Label -> Stmt
Jump Label
l]
patternSwitch SizeEnv
_ (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 SizeEnv
env (PatternCons ann :: ConsAnn MonoStackType
ann@(ConsAnn Int64
_ Word8
tag' MonoStackType
_) TyName (ConsAnn MonoStackType)
_) Label
l =
    let padAt :: Int64
padAt = SizeEnv -> ConsAnn MonoStackType -> Int64
padBytes SizeEnv
env 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 :: SizeEnv -> ConsAnn MonoStackType -> Int64
padBytes :: SizeEnv -> ConsAnn MonoStackType -> Int64
padBytes SizeEnv
env (ConsAnn Int64
sz Word8
_ ([KempeTy ()]
is, [KempeTy ()]
_)) = Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- SizeEnv -> [KempeTy ()] -> Int64
forall a. SizeEnv -> [KempeTy a] -> Int64
sizeStack SizeEnv
env [KempeTy ()]
is Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1

dipify :: SizeEnv -> Int64 -> Atom (ConsAnn MonoStackType) MonoStackType -> TempM [Stmt]
dipify :: SizeEnv
-> Int64
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
dipify SizeEnv
_ Int64
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Drop) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed drop!"
dipify SizeEnv
env Int64
sz (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Drop) =
    let sz' :: Int64
sz' = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 SizeEnv
env Int64
sz (AtBuiltin ([KempeTy ()
i0, KempeTy ()
i1], [KempeTy ()]
_) BuiltinFn
Swap) =
    let sz0 :: Int64
sz0 = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env KempeTy ()
i0
        sz1 :: Int64
sz1 = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env 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 SizeEnv
_ Int64
_ (Dip ([], [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
_) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dip()!"
dipify SizeEnv
env Int64
sz (Dip ([KempeTy ()]
is, [KempeTy ()]
_) [Atom (ConsAnn MonoStackType) MonoStackType]
as) =
    let sz' :: Int64
sz' = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 (SizeEnv
-> Int64
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
dipify SizeEnv
env (Int64
sz Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
sz')) [Atom (ConsAnn MonoStackType) MonoStackType]
as
dipify SizeEnv
_ Int64
_ (AtBuiltin MonoStackType
_ BuiltinFn
Swap)        = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed swap!"
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntTimes)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntTimesIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntPlus)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntPlusIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntMinus)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntMinusIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntDiv)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntDivIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntMod)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntModIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntXor)     = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntXorIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntEq)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntEqIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntLt)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntLtIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntLeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntLeqIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftL)  = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftLIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntShiftR)  = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftRIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordXor)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntXorIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftL) = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftLIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordShiftR) = Int64 -> IntBinOp -> TempM [Stmt]
dipShift Int64
sz IntBinOp
WordShiftRIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordPlus)   = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntPlusIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordTimes)  = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntTimesIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntGeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntGeqIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntGt)      = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntGtIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
IntNeq)     = Int64 -> RelBinOp -> TempM [Stmt]
dipRel Int64
sz RelBinOp
IntNeqIR
dipify SizeEnv
_ 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 SizeEnv
_ 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 SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
And)        = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolAnd
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
Or)         = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolOr
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
Xor)        = Int64 -> BoolBinOp -> TempM [Stmt]
dipBoolOp Int64
sz BoolBinOp
BoolXor
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordMinus)  = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
IntMinusIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordDiv)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
WordDivIR
dipify SizeEnv
_ Int64
sz (AtBuiltin MonoStackType
_ BuiltinFn
WordMod)    = Int64 -> IntBinOp -> TempM [Stmt]
dipOp Int64
sz IntBinOp
WordModIR
dipify SizeEnv
_ Int64
_ (AtBuiltin ([], [KempeTy ()]
_) BuiltinFn
Dup) = [Char] -> TempM [Stmt]
forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error: Ill-typed dup!"
dipify SizeEnv
env Int64
sz (AtBuiltin ([KempeTy ()]
is, [KempeTy ()]
_) BuiltinFn
Dup) = do
    let sz' :: Int64
sz' = SizeEnv -> KempeTy () -> Int64
forall a. SizeEnv -> KempeTy a -> Int64
size' SizeEnv
env ([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 SizeEnv
_ 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 SizeEnv
_ 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 SizeEnv
_ 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 SizeEnv
_ 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 SizeEnv
env 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 (SizeEnv -> ConsAnn MonoStackType -> Int64
padBytes SizeEnv
env 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 SizeEnv
env Int64
sz a :: Atom (ConsAnn MonoStackType) MonoStackType
a@(If MonoStackType
sty [Atom (ConsAnn MonoStackType) MonoStackType]
_ [Atom (ConsAnn MonoStackType) MonoStackType]
_) =
    SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp SizeEnv
env Int64
sz MonoStackType
sty ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
env Bool
False Atom (ConsAnn MonoStackType) MonoStackType
a
dipify SizeEnv
env Int64
sz (AtName MonoStackType
sty Name MonoStackType
n) =
    SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp SizeEnv
env 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 SizeEnv
env Int64
sz a :: Atom (ConsAnn MonoStackType) MonoStackType
a@(Case MonoStackType
sty NonEmpty
  (Pattern (ConsAnn MonoStackType) MonoStackType,
   [Atom (ConsAnn MonoStackType) MonoStackType])
_) =
    SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp SizeEnv
env Int64
sz MonoStackType
sty ([Stmt] -> [Stmt]) -> TempM [Stmt] -> TempM [Stmt]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SizeEnv
-> Bool
-> Atom (ConsAnn MonoStackType) MonoStackType
-> TempM [Stmt]
writeAtom SizeEnv
env Bool
False Atom (ConsAnn MonoStackType) MonoStackType
a

dipSupp :: SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp :: SizeEnv -> Int64 -> MonoStackType -> [Stmt] -> [Stmt]
dipSupp SizeEnv
env Int64
sz ([KempeTy ()]
is, [KempeTy ()]
os) [Stmt]
stmts =
    let excessSz :: Int64
excessSz = SizeEnv -> [KempeTy ()] -> Int64
forall a. SizeEnv -> [KempeTy a] -> Int64
sizeStack SizeEnv
env [KempeTy ()]
os Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- SizeEnv -> [KempeTy ()] -> Int64
forall a. SizeEnv -> [KempeTy a] -> Int64
sizeStack SizeEnv
env [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
            Ordering
GT -> Int64 -> Int64 -> [Stmt] -> [Stmt]
dipHelp Int64
excessSz Int64
sz [Stmt]
stmts

dipHelp :: Int64 -> Int64 -> [Stmt] -> [Stmt]
dipHelp :: Int64 -> Int64 -> [Stmt] -> [Stmt]
dipHelp Int64
excessSz Int64
dipSz [Stmt]
stmts =
    let shiftNext :: Stmt
shiftNext = Int64 -> Stmt
dataPointerDec Int64
dipSz
        shiftBack :: Stmt
shiftBack = Int64 -> Stmt
dataPointerInc Int64
dipSz
    in
    Stmt
shiftNext
        Stmt -> [Stmt] -> [Stmt]
forall a. a -> [a] -> [a]
: Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes Int64
excessSz (-Int64
dipSz) Int64
dipSz -- copy bytes past end of stack
        [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt]
stmts
        [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ Int64 -> Int64 -> Int64 -> [Stmt]
copyBytes (-Int64
dipSz) Int64
0 Int64
dipSz -- copy bytes back (now from 0 of stack; data pointer has been set)
        [Stmt] -> [Stmt] -> [Stmt]
forall a. [a] -> [a] -> [a]
++ [Stmt
shiftBack]

dipPush :: Int64 -> Int64 -> Exp -> [Stmt]
dipPush :: Int64 -> Int64 -> Exp -> [Stmt]
dipPush Int64
sz Int64
sz' Exp
e =
    -- FIXME: is this right?
    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 ]
    -- TODO: 4 byte chunks, &c. (would require more registers).
    | 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))