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