cogent/src/Cogent/Common/Types.hs

--
-- Copyright 2019, Data61
-- Commonwealth Scientific and Industrial Research Organisation (CSIRO)
-- ABN 41 687 119 230.
--
-- This software may be distributed and modified according to the terms of
-- the GNU General Public License version 2. Note that NO WARRANTY is provided.
-- See "LICENSE_GPLv2.txt" for details.
--
-- @TAG(DATA61_GPL)
--

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}

module Cogent.Common.Types where

import Cogent.Common.Syntax
import Cogent.Compiler
import Data.Binary (Binary)
import Data.Data
import Data.Map as M
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid
#endif
import GHC.Generics (Generic)
import Text.PrettyPrint.ANSI.Leijen hiding (tupled,indent)

type ReadOnly = Bool  -- True for r/o

data Sigil r = Boxed ReadOnly r  -- 0- or 1-kinded
             | Unboxed  -- 2-kinded
             deriving (Show, Data, Eq, Ord, Foldable, Functor, Generic, Traversable)

instance Binary r => Binary (Sigil r)

data RecursiveParameter = Rec VarName | NonRec deriving (Data, Show, Eq, Ord, Generic)

-- The context for a recursive type, i.e. a mapping from
-- recursive parameter names to the type it recursively references
type RecContext t = Maybe (M.Map RecParName t)

instance Binary RecursiveParameter

bangSigil :: Sigil r -> Sigil r
bangSigil (Boxed _ r)  = Boxed True r
bangSigil Unboxed      = Unboxed

unboxSigil :: Sigil r -> Sigil r
unboxSigil _ = Unboxed

writable :: Sigil r -> Bool
writable (Boxed False _) = True
writable _ = False

readonly :: Sigil r -> Bool
readonly (Boxed True _) = True
readonly _ = False

unboxed :: Sigil r -> Bool
unboxed Unboxed = True
unboxed _ = False

data PrimInt = U8 | U16 | U32 | U64 | Boolean deriving (Show, Data, Eq, Ord, Generic)

instance Binary PrimInt

machineWordType :: PrimInt
machineWordType = case __cogent_arch of
                    ARM32  -> U32
                    X86_32 -> U32
                    X86_64 -> U64

primIntSizeBits :: PrimInt -> Size
primIntSizeBits U8      = 8
primIntSizeBits U16     = 16
primIntSizeBits U32     = 32
primIntSizeBits U64     = 64
primIntSizeBits Boolean = 8


isSubtypePrim :: PrimInt -> PrimInt -> Bool
isSubtypePrim U8  U8  = True
isSubtypePrim U8  U16 = True
isSubtypePrim U8  U32 = True
isSubtypePrim U8  U64 = True
isSubtypePrim U16 U16 = True
isSubtypePrim U16 U32 = True
isSubtypePrim U16 U64 = True
isSubtypePrim U32 U32 = True
isSubtypePrim U32 U64 = True
isSubtypePrim U64 U64 = True
isSubtypePrim Boolean Boolean = True
isSubtypePrim _ _ = False

instance Pretty PrimInt where
  pretty = blue . bold . string . show

data Kind = K { canEscape :: Bool, canShare :: Bool, canDiscard :: Bool }
  deriving (Show, Data, Eq, Ord)

sigilKind :: Sigil r -> Kind
sigilKind (Boxed ro _) = if ro then k0 else k1
sigilKind Unboxed      = k2

k0, k1, k2 :: Kind
k0 = K False True  True
k1 = K True  False False
k2 = mempty
-- kAll = K False False False

#if __GLASGOW_HASKELL__ < 803
instance Monoid Kind where
  mempty = K True True True  -- 2-kind
  mappend (K a b c) (K a' b' c') = K (a && a') (b && b') (c && c')
    -- mappend   ka   0    1    2
    --    kb     +-----------------
    --    0      |    0    1x   0
    --    1      |    -    1    1
    --    2      |    -    -    2
    --    !      |    0    0    2
    -- 1x is a non-escapable linear kind
#else
instance Semigroup Kind where
  K a b c <> K a' b' c' = K (a && a') (b && b') (c && c')
instance Monoid Kind where
  mempty = K True True True
#endif

bangKind :: Kind -> Kind
bangKind (K e s d) = K (e && s && d) True True

primTypeCons :: [TypeName]
primTypeCons = words "U8 U16 U32 U64 Bool String"