1--
2-- Copyright 2019, Data61
3-- Commonwealth Scientific and Industrial Research Organisation (CSIRO)
4-- ABN 41 687 119 230.
5--
6-- This software may be distributed and modified according to the terms of
7-- the GNU General Public License version 2. Note that NO WARRANTY is provided.
8-- See "LICENSE_GPLv2.txt" for details.
9--
10-- @TAG(DATA61_GPL)
11--
12
13{-# LANGUAGE DeriveDataTypeable #-}
14{-# LANGUAGE DeriveFoldable #-}
15{-# LANGUAGE DeriveFunctor #-}
16{-# LANGUAGE DeriveGeneric #-}
17{-# LANGUAGE DeriveTraversable #-}
18
19module Cogent.Common.Types where
20
21import Cogent.Common.Syntax
22import Cogent.Compiler
23import Data.Binary (Binary)
24import Data.Data
25import Data.Map as M
26#if __GLASGOW_HASKELL__ < 709
27import Data.Monoid
28#endif
29import GHC.Generics (Generic)
30import Text.PrettyPrint.ANSI.Leijen hiding (tupled,indent)
31
32type ReadOnly = Bool  -- True for r/o
33
34data Sigil r = Boxed ReadOnly r  -- 0- or 1-kinded
35             | Unboxed  -- 2-kinded
36             deriving (Show, Data, Eq, Ord, Foldable, Functor, Generic, Traversable)
37
38instance Binary r => Binary (Sigil r)
39
40data RecursiveParameter = Rec VarName | NonRec deriving (Data, Show, Eq, Ord, Generic)
41
42-- The context for a recursive type, i.e. a mapping from
43-- recursive parameter names to the type it recursively references
44type RecContext t = Maybe (M.Map RecParName t)
45
46instance Binary RecursiveParameter
47
48bangSigil :: Sigil r -> Sigil r
49bangSigil (Boxed _ r)  = Boxed True r
50bangSigil Unboxed      = Unboxed
51
52unboxSigil :: Sigil r -> Sigil r
53unboxSigil _ = Unboxed
54
55writable :: Sigil r -> Bool
56writable (Boxed False _) = True
57writable _ = False
58
59readonly :: Sigil r -> Bool
60readonly (Boxed True _) = True
61readonly _ = False
62
63unboxed :: Sigil r -> Bool
64unboxed Unboxed = True
65unboxed _ = False
66
67data PrimInt = U8 | U16 | U32 | U64 | Boolean deriving (Show, Data, Eq, Ord, Generic)
68
69instance Binary PrimInt
70
71machineWordType :: PrimInt
72machineWordType = case __cogent_arch of
73                    ARM32  -> U32
74                    X86_32 -> U32
75                    X86_64 -> U64
76
77primIntSizeBits :: PrimInt -> Size
78primIntSizeBits U8      = 8
79primIntSizeBits U16     = 16
80primIntSizeBits U32     = 32
81primIntSizeBits U64     = 64
82primIntSizeBits Boolean = 8
83
84
85isSubtypePrim :: PrimInt -> PrimInt -> Bool
86isSubtypePrim U8  U8  = True
87isSubtypePrim U8  U16 = True
88isSubtypePrim U8  U32 = True
89isSubtypePrim U8  U64 = True
90isSubtypePrim U16 U16 = True
91isSubtypePrim U16 U32 = True
92isSubtypePrim U16 U64 = True
93isSubtypePrim U32 U32 = True
94isSubtypePrim U32 U64 = True
95isSubtypePrim U64 U64 = True
96isSubtypePrim Boolean Boolean = True
97isSubtypePrim _ _ = False
98
99instance Pretty PrimInt where
100  pretty = blue . bold . string . show
101
102data Kind = K { canEscape :: Bool, canShare :: Bool, canDiscard :: Bool }
103  deriving (Show, Data, Eq, Ord)
104
105sigilKind :: Sigil r -> Kind
106sigilKind (Boxed ro _) = if ro then k0 else k1
107sigilKind Unboxed      = k2
108
109k0, k1, k2 :: Kind
110k0 = K False True  True
111k1 = K True  False False
112k2 = mempty
113-- kAll = K False False False
114
115#if __GLASGOW_HASKELL__ < 803
116instance Monoid Kind where
117  mempty = K True True True  -- 2-kind
118  mappend (K a b c) (K a' b' c') = K (a && a') (b && b') (c && c')
119    -- mappend   ka   0    1    2
120    --    kb     +-----------------
121    --    0      |    0    1x   0
122    --    1      |    -    1    1
123    --    2      |    -    -    2
124    --    !      |    0    0    2
125    -- 1x is a non-escapable linear kind
126#else
127instance Semigroup Kind where
128  K a b c <> K a' b' c' = K (a && a') (b && b') (c && c')
129instance Monoid Kind where
130  mempty = K True True True
131#endif
132
133bangKind :: Kind -> Kind
134bangKind (K e s d) = K (e && s && d) True True
135
136primTypeCons :: [TypeName]
137primTypeCons = words "U8 U16 U32 U64 Bool String"
138