{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE EmptyDataDecls #-} {- | This module provides some functions from the "LLVM.Core.Instructions" module in a way that enables easier type handling. E.g. 'trunc' on vectors requires you to prove that reducing the bitsize of the elements reduces the bitsize of the whole vector. We solve the problem by adding a 'Guide' parameter. It can be either 'scalar' or 'vector'. We impose the bitsize constraint only on the element type, but not on the size of the whole value (scalar or vector). Another example: If you call 'trunc' on a Vector input, GHC cannot infer that the result must be a 'Data.Vector' of the same size. Using the guide, it can. However, in practice this is not as useful as I thought initially. -} module LLVM.Core.Instructions.Guided ( Guide, scalar, vector, getElementPtr, getElementPtr0, trunc, ext, extBool, zadapt, sadapt, adapt, fptrunc, fpext, fptoint, inttofp, ptrtoint, inttoptr, bitcast, select, cmp, icmp, pcmp, fcmp, ) where import qualified LLVM.Core.Instructions.Private as Priv import qualified LLVM.Core.Type as Type import qualified LLVM.Core.Util as U import qualified LLVM.Core.Proxy as LP import LLVM.Core.Instructions.Private (ValueCons, proxyFromValuePtr) import LLVM.Core.CodeGenMonad (CodeGenFunction) import LLVM.Core.CodeGen (ConstValue, Value, zero) import LLVM.Core.Data (Ptr) import LLVM.Core.Type (IsArithmetic, IsInteger, IsIntegerOrPointer, IsFloating, IsFirstClass, IsPrimitive, Signed, Positive, IsType, IsSized, SizeOf, isFloating, sizeOf, typeDesc, typeRef) import qualified LLVM.FFI.Core as FFI import Type.Data.Num.Decimal.Number ((:<:), (:>:)) import qualified Control.Functor.HT as FuncHT import Data.Word (Word32) data Guide shape elem = Guide instance Functor (Guide shape) where fmap _ Guide = Guide scalar :: Guide Type.ScalarShape a scalar = Guide vector :: (Positive n) => Guide (Type.VectorShape n) a vector = Guide proxyFromGuide :: Guide shape elem -> LP.Proxy elem proxyFromGuide Guide = LP.Proxy type Type shape a = Type.ShapedType shape a type VT value shape a = value (Type shape a) getElementPtr :: (ValueCons value, IsType o, Priv.GetElementPtr o i, Priv.IsIndexType i0) => Guide shape (Ptr o, i0) -> VT value shape (Ptr o) -> (VT value shape i0, i) -> CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i))) getElementPtr guide vptr (a, ixs) = getElementPtrGen (fmap fst guide) vptr (Priv.unValue a, ixs) getElementPtr0 :: (ValueCons value, IsType o, Priv.GetElementPtr o i) => Guide shape (Ptr o) -> VT value shape (Ptr o) -> i -> CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i))) getElementPtr0 guide vptr ixs = getElementPtrGen guide vptr (Priv.unConst (zero :: ConstValue Word32), ixs) getElementPtrGen :: (ValueCons value, IsType o, Priv.GetElementPtr o i) => Guide shape (Ptr o) -> VT value shape (Ptr o) -> (FFI.ValueRef, i) -> CodeGenFunction r (VT value shape (Ptr (Priv.ElementPtrType o i))) getElementPtrGen guide vptr (i0val,ixs) = let withArgs act = U.withArrayLen (i0val : Priv.getIxList (LP.element (proxyFromGuide guide)) ixs) $ \ idxLen idxPtr -> act idxPtr (fromIntegral idxLen) in Priv.unop (\ptr -> do typ <- typeRef $ proxyFromValuePtr guide withArgs $ FFI.constGEP2 typ ptr) (\bldPtr ptr cstr -> do typ <- typeRef $ proxyFromValuePtr guide withArgs $ \idxPtr idxLen -> FFI.buildGEP2 bldPtr typ ptr idxPtr idxLen cstr) vptr -- | Truncate a value to a shorter bit width. trunc :: (ValueCons value, IsInteger av, IsInteger bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, IsSized a, IsSized b, SizeOf a :>: SizeOf b) => Guide shape (a,b) -> value av -> CodeGenFunction r (value bv) trunc = convert FFI.constTrunc FFI.buildTrunc isSigned :: (IsArithmetic a) => Guide shape a -> Bool isSigned = Type.isSigned . proxyFromGuide -- | Extend a value to wider width. -- If the target type is signed, then preserve the sign, -- If the target type is unsigned, then extended by zeros. ext :: (IsInteger a, IsInteger b, IsType bv, Signed a ~ Signed b, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) ext guide = if isSigned (fmap snd guide) then convertValue FFI.buildSExt guide else convertValue FFI.buildZExt guide extBool :: (IsInteger b, IsType bv, IsPrimitive b, Type shape Bool ~ av, Type shape b ~ bv) => Guide shape (Bool,b) -> Value av -> CodeGenFunction r (Value bv) extBool guide = if isSigned (fmap snd guide) then convertValue FFI.buildSExt guide else convertValue FFI.buildZExt guide compareGuideSizes :: (IsType a, IsType b) => Guide shape (a,b) -> Ordering compareGuideSizes guide = case FuncHT.unzip $ proxyFromGuide guide of (a,b) -> compare (sizeOf (typeDesc a)) (sizeOf (typeDesc b)) -- | It is 'zext', 'trunc' or nop depending on the relation of the sizes. zadapt :: (IsInteger a, IsInteger b, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) zadapt guide = case compareGuideSizes guide of LT -> convertValue FFI.buildZExt guide EQ -> convertValue FFI.buildBitCast guide GT -> convertValue FFI.buildTrunc guide -- | It is 'sext', 'trunc' or nop depending on the relation of the sizes. sadapt :: (IsInteger a, IsInteger b, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) sadapt guide = case compareGuideSizes guide of LT -> convertValue FFI.buildSExt guide EQ -> convertValue FFI.buildBitCast guide GT -> convertValue FFI.buildTrunc guide -- | It is 'sadapt' or 'zadapt' depending on the sign mode. adapt :: (IsInteger a, IsInteger b, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, Signed a ~ Signed b) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) adapt guide = case compareGuideSizes guide of LT -> if isSigned (fmap snd guide) then convertValue FFI.buildSExt guide else convertValue FFI.buildZExt guide EQ -> convertValue FFI.buildBitCast guide GT -> convertValue FFI.buildTrunc guide -- | Truncate a floating point value. fptrunc :: (IsFloating av, IsFloating bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, IsSized a, IsSized b, SizeOf a :>: SizeOf b) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) fptrunc = convertValue FFI.buildFPTrunc -- | Extend a floating point value. fpext :: (IsFloating av, IsFloating bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, IsSized a, IsSized b, SizeOf a :<: SizeOf b) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) fpext = convertValue FFI.buildFPExt -- | Convert a floating point value to an integer. -- It is mapped to @fptosi@ or @fptoui@ depending on the type @a@. fptoint :: (IsFloating a, IsInteger b, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) fptoint guide = if isSigned (fmap snd guide) then convertValue FFI.buildFPToSI guide else convertValue FFI.buildFPToUI guide -- | Convert an integer to a floating point value. -- It is mapped to @sitofp@ or @uitofp@ depending on the type @a@. inttofp :: (IsInteger a, IsFloating b, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) inttofp guide = if isSigned (fmap fst guide) then convertValue FFI.buildSIToFP guide else convertValue FFI.buildUIToFP guide -- | Convert a pointer to an integer. ptrtoint :: (ValueCons value, IsType a, IsInteger b, IsType bv, IsPrimitive b, Type shape (Ptr a) ~ av, Type shape b ~ bv) => Guide shape (Ptr a, b) -> value av -> CodeGenFunction r (value bv) ptrtoint = convert FFI.constPtrToInt FFI.buildPtrToInt -- | Convert an integer to a pointer. inttoptr :: (ValueCons value, IsInteger a, IsType b, IsType bv, IsPrimitive a, Type shape a ~ av, Type shape (Ptr b) ~ bv) => Guide shape (a, Ptr b) -> value av -> CodeGenFunction r (value bv) inttoptr = convert FFI.constIntToPtr FFI.buildIntToPtr -- | Convert between to values of the same size by just copying the bit pattern. bitcast :: (ValueCons value, IsFirstClass bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv, IsSized a, IsSized b, SizeOf a ~ SizeOf b) => Guide shape (a,b) -> value av -> CodeGenFunction r (value bv) bitcast = convert FFI.constBitCast FFI.buildBitCast convert :: (ValueCons value, IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Priv.FFIConstConvert -> Priv.FFIConvert -> Guide shape (a,b) -> value av -> CodeGenFunction r (value bv) convert cnvConst cnv Guide = Priv.convert cnvConst cnv convertValue :: (IsType bv, IsPrimitive a, IsPrimitive b, Type shape a ~ av, Type shape b ~ bv) => Priv.FFIConvert -> Guide shape (a,b) -> Value av -> CodeGenFunction r (Value bv) convertValue cnv Guide = Priv.convertValue LP.Proxy cnv select :: (IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> Value bv -> Value av -> Value av -> CodeGenFunction r (Value av) select Guide = Priv.trinopValue FFI.buildSelect cmp :: (IsArithmetic a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> Priv.CmpPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv) cmp guide@Guide p = let cmpop buildCmp predi = Priv.binopValue (flip buildCmp predi) in if isFloating (proxyFromGuide guide) then cmpop FFI.buildFCmp $ FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p else cmpop FFI.buildICmp $ FFI.fromIntPredicate $ if isSigned guide then Priv.sintFromCmpPredicate p else Priv.uintFromCmpPredicate p _cmp :: (IsArithmetic a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> Priv.CmpPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv) _cmp guide@Guide p = if isFloating (proxyFromGuide guide) then let predi = FFI.fromRealPredicate $ Priv.fpFromCmpPredicate p in Priv.binopValue (flip FFI.buildFCmp predi) else let predi = FFI.fromIntPredicate $ if isSigned guide then Priv.sintFromCmpPredicate p else Priv.uintFromCmpPredicate p in Priv.binopValue (flip FFI.buildICmp predi) {-# DEPRECATED icmp "use cmp or pcmp instead" #-} -- | Compare integers. icmp :: (IsIntegerOrPointer a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> FFI.IntPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv) icmp Guide p = Priv.binopValue $ flip FFI.buildICmp (FFI.fromIntPredicate p) -- | Compare pointers. pcmp :: (Type shape (Ptr a) ~ av, Type shape Bool ~ bv) => Guide shape (Ptr a) -> FFI.IntPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv) pcmp Guide p = Priv.binopValue $ flip FFI.buildICmp (FFI.fromIntPredicate p) -- | Compare floating point values. fcmp :: (IsFloating a, IsPrimitive a, Type shape a ~ av, Type shape Bool ~ bv) => Guide shape a -> FFI.FPPredicate -> Value av -> Value av -> CodeGenFunction r (Value bv) fcmp Guide p = Priv.binopValue $ flip FFI.buildFCmp (FFI.fromRealPredicate p)