diff options
| -rw-r--r-- | compiler/cmm/CmmMachOp.hs | 10 | ||||
| -rw-r--r-- | compiler/cmm/PprC.hs | 9 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmPrim.hs | 288 | ||||
| -rw-r--r-- | compiler/ghc.mk | 16 | ||||
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 6 | ||||
| -rw-r--r-- | compiler/nativeGen/X86/CodeGen.hs | 2 | ||||
| -rw-r--r-- | compiler/prelude/PrelNames.lhs | 15 | ||||
| -rw-r--r-- | compiler/prelude/PrimOp.lhs | 11 | ||||
| -rw-r--r-- | compiler/prelude/TysPrim.lhs | 40 | ||||
| -rw-r--r-- | compiler/prelude/primops.txt.pp | 518 | ||||
| -rw-r--r-- | utils/genprimopcode/Lexer.x | 8 | ||||
| -rw-r--r-- | utils/genprimopcode/Main.hs | 373 | ||||
| -rw-r--r-- | utils/genprimopcode/Parser.y | 29 | ||||
| -rw-r--r-- | utils/genprimopcode/ParserM.hs | 8 | ||||
| -rw-r--r-- | utils/genprimopcode/Syntax.hs | 42 |
15 files changed, 723 insertions, 652 deletions
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs index 8d42bbd2cb..c009d15e25 100644 --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -118,6 +118,10 @@ data MachOp | MO_VS_Rem Length Width | MO_VS_Neg Length Width + -- Unsigned vector multiply/divide + | MO_VU_Quot Length Width + | MO_VU_Rem Length Width + -- Floting point vector element insertion and extraction operations | MO_VF_Insert Length Width -- Insert scalar into vector | MO_VF_Extract Length Width -- Extract scalar from vector @@ -375,6 +379,9 @@ machOpResultType dflags mop tys = MO_VS_Rem l w -> cmmVec l (cmmBits w) MO_VS_Neg l w -> cmmVec l (cmmBits w) + MO_VU_Quot l w -> cmmVec l (cmmBits w) + MO_VU_Rem l w -> cmmVec l (cmmBits w) + MO_VF_Insert l w -> cmmVec l (cmmFloat w) MO_VF_Extract _ w -> cmmFloat w @@ -461,6 +468,9 @@ machOpArgReps dflags op = MO_VS_Rem _ r -> [r,r] MO_VS_Neg _ r -> [r] + MO_VU_Quot _ r -> [r,r] + MO_VU_Rem _ r -> [r,r] + MO_VF_Insert l r -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags] MO_VF_Extract l r -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags] diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index d45b103954..c468161c73 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -651,6 +651,15 @@ pprMachOp_for_C mop = case mop of (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg" ++ " should have been handled earlier!") + MO_VU_Quot {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VU_Quot") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot" + ++ " should have been handled earlier!") + MO_VU_Rem {} -> pprTrace "offending mop:" + (ptext $ sLit "MO_VU_Rem") + (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem" + ++ " should have been handled earlier!") + MO_VF_Insert {} -> pprTrace "offending mop:" (ptext $ sLit "MO_VF_Insert") (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert" diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 8560f7cf1c..5250c9378e 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -40,7 +40,7 @@ import FastString import Outputable import Util -import Control.Monad (liftM) +import Control.Monad (liftM, when) import Data.Bits ------------------------------------------------------------------------ @@ -380,14 +380,6 @@ emitPrimOp dflags res IndexOffAddrOp_Word8 args = doIndexOffAddrOp emitPrimOp dflags res IndexOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args emitPrimOp dflags res IndexOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ res IndexOffAddrOp_FloatX4 args = doIndexOffAddrOp Nothing vec4f32 res args -emitPrimOp _ res IndexOffAddrOp_FloatAsFloatX4 args = doIndexOffAddrOpAs Nothing vec4f32 f32 res args -emitPrimOp _ res IndexOffAddrOp_DoubleX2 args = doIndexOffAddrOp Nothing vec2f64 res args -emitPrimOp _ res IndexOffAddrOp_DoubleAsDoubleX2 args = doIndexOffAddrOpAs Nothing vec2f64 f64 res args -emitPrimOp _ res IndexOffAddrOp_Int32X4 args = doIndexOffAddrOp Nothing vec4b32 res args -emitPrimOp _ res IndexOffAddrOp_Int32AsInt32X4 args = doIndexOffAddrOpAs Nothing vec4b32 b32 res args -emitPrimOp _ res IndexOffAddrOp_Int64X2 args = doIndexOffAddrOp Nothing vec2b64 res args -emitPrimOp _ res IndexOffAddrOp_Int64AsInt64X2 args = doIndexOffAddrOpAs Nothing vec2b64 b64 res args -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr. @@ -407,14 +399,6 @@ emitPrimOp dflags res ReadOffAddrOp_Word8 args = doIndexOffAddrOp ( emitPrimOp dflags res ReadOffAddrOp_Word16 args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args emitPrimOp dflags res ReadOffAddrOp_Word32 args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadOffAddrOp_Word64 args = doIndexOffAddrOp Nothing b64 res args -emitPrimOp _ res ReadOffAddrOp_FloatX4 args = doIndexOffAddrOp Nothing vec4f32 res args -emitPrimOp _ res ReadOffAddrOp_FloatAsFloatX4 args = doIndexOffAddrOpAs Nothing vec4f32 b32 res args -emitPrimOp _ res ReadOffAddrOp_DoubleX2 args = doIndexOffAddrOp Nothing vec2f64 res args -emitPrimOp _ res ReadOffAddrOp_DoubleAsDoubleX2 args = doIndexOffAddrOpAs Nothing vec2f64 b64 res args -emitPrimOp _ res ReadOffAddrOp_Int32X4 args = doIndexOffAddrOp Nothing vec4b32 res args -emitPrimOp _ res ReadOffAddrOp_Int32AsInt32X4 args = doIndexOffAddrOpAs Nothing vec4b32 b32 res args -emitPrimOp _ res ReadOffAddrOp_Int64X2 args = doIndexOffAddrOp Nothing vec2b64 res args -emitPrimOp _ res ReadOffAddrOp_Int64AsInt64X2 args = doIndexOffAddrOpAs Nothing vec2b64 b64 res args -- IndexXXXArray @@ -434,14 +418,6 @@ emitPrimOp dflags res IndexByteArrayOp_Word8 args = doIndexByteArrayO emitPrimOp dflags res IndexByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args emitPrimOp dflags res IndexByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res IndexByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ res IndexByteArrayOp_FloatX4 args = doIndexByteArrayOp Nothing vec4f32 res args -emitPrimOp _ res IndexByteArrayOp_FloatAsFloatX4 args = doIndexByteArrayOpAs Nothing vec4f32 f32 res args -emitPrimOp _ res IndexByteArrayOp_DoubleX2 args = doIndexByteArrayOp Nothing vec2f64 res args -emitPrimOp _ res IndexByteArrayOp_DoubleAsDoubleX2 args = doIndexByteArrayOpAs Nothing vec2f64 f64 res args -emitPrimOp _ res IndexByteArrayOp_Int32X4 args = doIndexByteArrayOp Nothing vec4b32 res args -emitPrimOp _ res IndexByteArrayOp_Int32AsInt32X4 args = doIndexByteArrayOpAs Nothing vec4b32 b32 res args -emitPrimOp _ res IndexByteArrayOp_Int64X2 args = doIndexByteArrayOp Nothing vec2b64 res args -emitPrimOp _ res IndexByteArrayOp_Int64AsInt64X2 args = doIndexByteArrayOpAs Nothing vec2b64 b64 res args -- ReadXXXArray, identical to IndexXXXArray. @@ -461,14 +437,6 @@ emitPrimOp dflags res ReadByteArrayOp_Word8 args = doIndexByteArrayOp emitPrimOp dflags res ReadByteArrayOp_Word16 args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16 res args emitPrimOp dflags res ReadByteArrayOp_Word32 args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args emitPrimOp _ res ReadByteArrayOp_Word64 args = doIndexByteArrayOp Nothing b64 res args -emitPrimOp _ res ReadByteArrayOp_FloatX4 args = doIndexByteArrayOp Nothing vec4f32 res args -emitPrimOp _ res ReadByteArrayOp_FloatAsFloatX4 args = doIndexByteArrayOpAs Nothing vec4f32 f32 res args -emitPrimOp _ res ReadByteArrayOp_DoubleX2 args = doIndexByteArrayOp Nothing vec2f64 res args -emitPrimOp _ res ReadByteArrayOp_DoubleAsDoubleX2 args = doIndexByteArrayOpAs Nothing vec2f64 f64 res args -emitPrimOp _ res ReadByteArrayOp_Int32X4 args = doIndexByteArrayOp Nothing vec4b32 res args -emitPrimOp _ res ReadByteArrayOp_Int32AsInt32X4 args = doIndexByteArrayOpAs Nothing vec4b32 b32 res args -emitPrimOp _ res ReadByteArrayOp_Int64X2 args = doIndexByteArrayOp Nothing vec2b64 res args -emitPrimOp _ res ReadByteArrayOp_Int64AsInt64X2 args = doIndexByteArrayOpAs Nothing vec2b64 b64 res args -- WriteXXXoffAddr @@ -488,14 +456,6 @@ emitPrimOp dflags res WriteOffAddrOp_Word8 args = doWriteOffAddrOp (J emitPrimOp dflags res WriteOffAddrOp_Word16 args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args emitPrimOp dflags res WriteOffAddrOp_Word32 args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteOffAddrOp_Word64 args = doWriteOffAddrOp Nothing b64 res args -emitPrimOp _ res WriteOffAddrOp_FloatX4 args = doWriteOffAddrOp Nothing vec4f32 res args -emitPrimOp _ res WriteOffAddrOp_FloatAsFloatX4 args = doWriteOffAddrOp Nothing f32 res args -emitPrimOp _ res WriteOffAddrOp_DoubleX2 args = doWriteOffAddrOp Nothing vec2f64 res args -emitPrimOp _ res WriteOffAddrOp_DoubleAsDoubleX2 args = doWriteOffAddrOp Nothing f64 res args -emitPrimOp _ res WriteOffAddrOp_Int32X4 args = doWriteOffAddrOp Nothing vec4b32 res args -emitPrimOp _ res WriteOffAddrOp_Int32AsInt32X4 args = doWriteOffAddrOp Nothing b32 res args -emitPrimOp _ res WriteOffAddrOp_Int64X2 args = doWriteOffAddrOp Nothing vec2b64 res args -emitPrimOp _ res WriteOffAddrOp_Int64AsInt64X2 args = doWriteOffAddrOp Nothing b64 res args -- WriteXXXArray @@ -515,14 +475,6 @@ emitPrimOp dflags res WriteByteArrayOp_Word8 args = doWriteByteArrayO emitPrimOp dflags res WriteByteArrayOp_Word16 args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args emitPrimOp dflags res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args emitPrimOp _ res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing b64 res args -emitPrimOp _ res WriteByteArrayOp_FloatX4 args = doWriteByteArrayOp Nothing vec4f32 res args -emitPrimOp _ res WriteByteArrayOp_FloatAsFloatX4 args = doWriteByteArrayOp Nothing f32 res args -emitPrimOp _ res WriteByteArrayOp_DoubleX2 args = doWriteByteArrayOp Nothing vec2f64 res args -emitPrimOp _ res WriteByteArrayOp_DoubleAsDoubleX2 args = doWriteByteArrayOp Nothing f64 res args -emitPrimOp _ res WriteByteArrayOp_Int32X4 args = doWriteByteArrayOp Nothing vec4b32 res args -emitPrimOp _ res WriteByteArrayOp_Int32AsInt32X4 args = doWriteByteArrayOp Nothing b32 res args -emitPrimOp _ res WriteByteArrayOp_Int64X2 args = doWriteByteArrayOp Nothing vec2b64 res args -emitPrimOp _ res WriteByteArrayOp_Int64AsInt64X2 args = doWriteByteArrayOp Nothing b64 res args -- Copying and setting byte arrays emitPrimOp _ [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = @@ -556,78 +508,136 @@ emitPrimOp _ [res] Word2FloatOp [w] = emitPrimCall [res] emitPrimOp _ [res] Word2DoubleOp [w] = emitPrimCall [res] (MO_UF_Conv W64) [w] --- SIMD vector packing and unpacking -emitPrimOp _ [res] FloatToFloatX4Op [e] = - doVecPackOp Nothing vec4f32 zero [e,e,e,e] res +-- SIMD primops +emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = + doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 4 (CmmFloat 0 W32)) + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags [res] (VecPackOp vcat n w) es = do + when (length es /= n) $ + panic "emitPrimOp: VecPackOp has wrong number of arguments" + doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res + where + zeros :: CmmExpr + zeros = CmmLit $ CmmVec (replicate n zero) + + zero :: CmmLit + zero = case vcat of + IntVec -> CmmInt 0 w + WordVec -> CmmInt 0 w + FloatVec -> CmmFloat 0 w + + ty :: CmmType + ty = vecVmmType vcat n w + +emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do + when (length res /= n) $ + panic "emitPrimOp: VecUnpackOp has wrong number of results" + doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res + where + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ [res] FloatX4PackOp es@[_,_,_,_] = - doVecPackOp Nothing vec4f32 zero es res +emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = + doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 4 (CmmFloat 0 W32)) + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ res@[_,_,_,_] FloatX4UnpackOp [arg] = - doVecUnpackOp Nothing vec4f32 arg res +emitPrimOp _ res (VecIndexByteArrayOp vcat n w) args = + doIndexByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ [res] FloatX4InsertOp [v,e,i] = - doVecInsertOp Nothing vec4f32 v e i res +emitPrimOp _ res (VecReadByteArrayOp vcat n w) args = + doIndexByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ [res] DoubleToDoubleX2Op [e] = - doVecPackOp Nothing vec2f64 zero [e,e] res +emitPrimOp _ res (VecWriteByteArrayOp vcat n w) args = + doWriteByteArrayOp Nothing ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 2 (CmmFloat 0 W64)) + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ [res] DoubleX2PackOp es@[_,_] = - doVecPackOp Nothing vec2f64 zero es res +emitPrimOp _ res (VecIndexOffAddrOp vcat n w) args = + doIndexOffAddrOp Nothing ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 2 (CmmFloat 0 W64)) + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ res@[_,_] DoubleX2UnpackOp [arg] = - doVecUnpackOp Nothing vec2f64 arg res +emitPrimOp _ res (VecReadOffAddrOp vcat n w) args = + doIndexOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp _ [res] DoubleX2InsertOp [v,e,i] = - doVecInsertOp Nothing vec2f64 v e i res +emitPrimOp _ res (VecWriteOffAddrOp vcat n w) args = + doWriteOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecVmmType vcat n w -emitPrimOp dflags [res] Int32ToInt32X4Op [e] = - doVecPackOp (Just (mo_WordTo32 dflags)) vec4b32 zero [e,e,e,e] res +emitPrimOp _ res (VecIndexScalarByteArrayOp vcat n w) args = + doIndexByteArrayOpAs Nothing vecty ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 4 (CmmInt 0 W32)) + vecty :: CmmType + vecty = vecVmmType vcat n w -emitPrimOp dflags [res] Int32X4PackOp es@[_,_,_,_] = - doVecPackOp (Just (mo_WordTo32 dflags)) vec4b32 zero es res + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp _ res (VecReadScalarByteArrayOp vcat n w) args = + doIndexByteArrayOpAs Nothing vecty ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 4 (CmmInt 0 W32)) + vecty :: CmmType + vecty = vecVmmType vcat n w -emitPrimOp dflags res@[_,_,_,_] Int32X4UnpackOp [arg] = - doVecUnpackOp (Just (mo_s_32ToWord dflags)) vec4b32 arg res + ty :: CmmType + ty = vecCmmCat vcat w -emitPrimOp dflags [res] Int32X4InsertOp [v,e,i] = - doVecInsertOp (Just (mo_WordTo32 dflags)) vec4b32 v e i res +emitPrimOp _ res (VecWriteScalarByteArrayOp vcat _ w) args = + doWriteByteArrayOp Nothing ty res args + where + ty :: CmmType + ty = vecCmmCat vcat w -emitPrimOp _ [res] Int64ToInt64X2Op [e] = - doVecPackOp Nothing vec2b64 zero [e,e] res +emitPrimOp _ res (VecIndexScalarOffAddrOp vcat n w) args = + doIndexOffAddrOpAs Nothing vecty ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 2 (CmmInt 0 W64)) + vecty :: CmmType + vecty = vecVmmType vcat n w -emitPrimOp _ [res] Int64X2PackOp es@[_,_] = - doVecPackOp Nothing vec2b64 zero es res + ty :: CmmType + ty = vecCmmCat vcat w + +emitPrimOp _ res (VecReadScalarOffAddrOp vcat n w) args = + doIndexOffAddrOpAs Nothing vecty ty res args where - zero :: CmmExpr - zero = CmmLit $ CmmVec (replicate 2 (CmmInt 0 W64)) + vecty :: CmmType + vecty = vecVmmType vcat n w -emitPrimOp _ res@[_,_] Int64X2UnpackOp [arg] = - doVecUnpackOp Nothing vec2b64 arg res + ty :: CmmType + ty = vecCmmCat vcat w -emitPrimOp _ [res] Int64X2InsertOp [v,e,i] = - doVecInsertOp Nothing vec2b64 v e i res +emitPrimOp _ res (VecWriteScalarOffAddrOp vcat _ w) args = + doWriteOffAddrOp Nothing ty res args + where + ty :: CmmType + ty = vecCmmCat vcat w -- Prefetch emitPrimOp _ res PrefetchByteArrayOp args = doPrefetchByteArrayOp res args @@ -944,33 +954,26 @@ translateOp _ FloatMulOp = Just (MO_F_Mul W32) translateOp _ FloatDivOp = Just (MO_F_Quot W32) translateOp _ FloatNegOp = Just (MO_F_Neg W32) --- Floating point vector ops - -translateOp _ FloatX4AddOp = Just (MO_VF_Add 4 W32) -translateOp _ FloatX4SubOp = Just (MO_VF_Sub 4 W32) -translateOp _ FloatX4MulOp = Just (MO_VF_Mul 4 W32) -translateOp _ FloatX4DivOp = Just (MO_VF_Quot 4 W32) -translateOp _ FloatX4NegOp = Just (MO_VF_Neg 4 W32) - -translateOp _ DoubleX2AddOp = Just (MO_VF_Add 2 W64) -translateOp _ DoubleX2SubOp = Just (MO_VF_Sub 2 W64) -translateOp _ DoubleX2MulOp = Just (MO_VF_Mul 2 W64) -translateOp _ DoubleX2DivOp = Just (MO_VF_Quot 2 W64) -translateOp _ DoubleX2NegOp = Just (MO_VF_Neg 2 W64) - -translateOp _ Int32X4AddOp = Just (MO_V_Add 4 W32) -translateOp _ Int32X4SubOp = Just (MO_V_Sub 4 W32) -translateOp _ Int32X4MulOp = Just (MO_V_Mul 4 W32) -translateOp _ Int32X4QuotOp = Just (MO_VS_Quot 4 W32) -translateOp _ Int32X4RemOp = Just (MO_VS_Rem 4 W32) -translateOp _ Int32X4NegOp = Just (MO_VS_Neg 4 W32) - -translateOp _ Int64X2AddOp = Just (MO_V_Add 2 W64) -translateOp _ Int64X2SubOp = Just (MO_V_Sub 2 W64) -translateOp _ Int64X2MulOp = Just (MO_V_Mul 2 W64) -translateOp _ Int64X2QuotOp = Just (MO_VS_Quot 2 W64) -translateOp _ Int64X2RemOp = Just (MO_VS_Rem 2 W64) -translateOp _ Int64X2NegOp = Just (MO_VS_Neg 2 W64) +-- Vector ops + +translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add n w) +translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub n w) +translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul n w) +translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w) +translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg n w) + +translateOp _ (VecAddOp IntVec n w) = Just (MO_V_Add n w) +translateOp _ (VecSubOp IntVec n w) = Just (MO_V_Sub n w) +translateOp _ (VecMulOp IntVec n w) = Just (MO_V_Mul n w) +translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w) +translateOp _ (VecRemOp IntVec n w) = Just (MO_VS_Rem n w) +translateOp _ (VecNegOp IntVec n w) = Just (MO_VS_Neg n w) + +translateOp _ (VecAddOp WordVec n w) = Just (MO_V_Add n w) +translateOp _ (VecSubOp WordVec n w) = Just (MO_V_Sub n w) +translateOp _ (VecMulOp WordVec n w) = Just (MO_V_Mul n w) +translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w) +translateOp _ (VecRemOp WordVec n w) = Just (MO_VU_Rem n w) -- Conversions @@ -1183,6 +1186,41 @@ setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr ------------------------------------------------------------------------------ +-- Helpers for translating vector primops. + +vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType +vecVmmType pocat n w = vec n (vecCmmCat pocat w) + +vecCmmCat :: PrimOpVecCat -> Width -> CmmType +vecCmmCat IntVec = cmmBits +vecCmmCat WordVec = cmmBits +vecCmmCat FloatVec = cmmFloat + +vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemInjectCast _ FloatVec _ = Nothing +vecElemInjectCast dflags IntVec W8 = Just (mo_WordTo8 dflags) +vecElemInjectCast dflags IntVec W16 = Just (mo_WordTo16 dflags) +vecElemInjectCast dflags IntVec W32 = Just (mo_WordTo32 dflags) +vecElemInjectCast _ IntVec W64 = Nothing +vecElemInjectCast dflags WordVec W8 = Just (mo_WordTo8 dflags) +vecElemInjectCast dflags WordVec W16 = Just (mo_WordTo16 dflags) +vecElemInjectCast dflags WordVec W32 = Just (mo_WordTo32 dflags) +vecElemInjectCast _ WordVec W64 = Nothing +vecElemInjectCast _ _ _ = Nothing + +vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp +vecElemProjectCast _ FloatVec _ = Nothing +vecElemProjectCast dflags IntVec W8 = Just (mo_s_8ToWord dflags) +vecElemProjectCast dflags IntVec W16 = Just (mo_s_16ToWord dflags) +vecElemProjectCast dflags IntVec W32 = Just (mo_s_32ToWord dflags) +vecElemProjectCast _ IntVec W64 = Nothing +vecElemProjectCast dflags WordVec W8 = Just (mo_u_8ToWord dflags) +vecElemProjectCast dflags WordVec W16 = Just (mo_u_16ToWord dflags) +vecElemProjectCast dflags WordVec W32 = Just (mo_u_32ToWord dflags) +vecElemProjectCast _ WordVec W64 = Nothing +vecElemProjectCast _ _ _ = Nothing + +------------------------------------------------------------------------------ -- Helpers for translating vector packing and unpacking. doVecPackOp :: Maybe MachOp -- Cast from element to vector component diff --git a/compiler/ghc.mk b/compiler/ghc.mk index 4fdadd7c30..5b9610103b 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -250,8 +250,12 @@ PRIMOP_BITS_NAMES = primop-data-decl.hs-incl \ primop-code-size.hs-incl \ primop-can-fail.hs-incl \ primop-strictness.hs-incl \ - primop-fixity.hs-incl \ - primop-primop-info.hs-incl + primop-fixity.hs-incl \ + primop-primop-info.hs-incl \ + primop-vector-uniques.hs-incl \ + primop-vector-tys.hs-incl \ + primop-vector-tys-exports.hs-incl \ + primop-vector-tycons.hs-incl PRIMOP_BITS_STAGE1 = $(addprefix compiler/stage1/build/,$(PRIMOP_BITS_NAMES)) PRIMOP_BITS_STAGE2 = $(addprefix compiler/stage2/build/,$(PRIMOP_BITS_NAMES)) @@ -290,6 +294,14 @@ compiler/stage$1/build/primop-fixity.hs-incl: compiler/stage$1/build/primops.txt "$$(genprimopcode_INPLACE)" --fixity < $$< > $$@ compiler/stage$1/build/primop-primop-info.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) "$$(genprimopcode_INPLACE)" --primop-primop-info < $$< > $$@ +compiler/stage$1/build/primop-vector-uniques.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-uniques < $$< > $$@ +compiler/stage$1/build/primop-vector-tys.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tys < $$< > $$@ +compiler/stage$1/build/primop-vector-tys-exports.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tys-exports < $$< > $$@ +compiler/stage$1/build/primop-vector-tycons.hs-incl: compiler/stage$1/build/primops.txt $$$$(genprimopcode_INPLACE) + "$$(genprimopcode_INPLACE)" --primop-vector-tycons < $$< > $$@ # Usages aren't used any more; but the generator # can still generate them if we want them back diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index 33107c0b68..c52640b17f 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -967,6 +967,9 @@ genMachOp _ op [x] = case op of MO_VS_Quot _ _ -> panicOp MO_VS_Rem _ _ -> panicOp + + MO_VU_Quot _ _ -> panicOp + MO_VU_Rem _ _ -> panicOp MO_VF_Insert _ _ -> panicOp MO_VF_Extract _ _ -> panicOp @@ -1140,6 +1143,9 @@ genMachOp_slow opt op [x, y] = case op of MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem + + MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv + MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index f6143d3fb9..e18da25347 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -610,6 +610,8 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps MO_VS_Quot {} -> needLlvm MO_VS_Rem {} -> needLlvm MO_VS_Neg {} -> needLlvm + MO_VU_Quot {} -> needLlvm + MO_VU_Rem {} -> needLlvm MO_VF_Insert {} -> needLlvm MO_VF_Extract {} -> needLlvm MO_VF_Add {} -> needLlvm diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 81fb9be52a..07730e653d 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1474,15 +1474,6 @@ typeNatMulTyFamNameKey = mkPreludeTyConUnique 163 typeNatExpTyFamNameKey = mkPreludeTyConUnique 164 typeNatLeqTyFamNameKey = mkPreludeTyConUnique 165 --- SIMD vector types (Unique keys) -floatX4PrimTyConKey, doubleX2PrimTyConKey, int32X4PrimTyConKey, - int64X2PrimTyConKey :: Unique - -floatX4PrimTyConKey = mkPreludeTyConUnique 170 -doubleX2PrimTyConKey = mkPreludeTyConUnique 171 -int32X4PrimTyConKey = mkPreludeTyConUnique 172 -int64X2PrimTyConKey = mkPreludeTyConUnique 173 - ntTyConKey:: Unique ntTyConKey = mkPreludeTyConUnique 174 coercibleTyConKey :: Unique @@ -1492,6 +1483,12 @@ coercibleTyConKey = mkPreludeTyConUnique 175 -- USES TyConUniques 200-299 ----------------------------------------------------- +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + unitTyConKey :: Unique unitTyConKey = mkTupleTyConUnique BoxedTuple 0 \end{code} diff --git a/compiler/prelude/PrimOp.lhs b/compiler/prelude/PrimOp.lhs index 8b1970c37f..22753ee3ea 100644 --- a/compiler/prelude/PrimOp.lhs +++ b/compiler/prelude/PrimOp.lhs @@ -5,7 +5,7 @@ \begin{code} module PrimOp ( - PrimOp(..), allThePrimOps, + PrimOp(..), PrimOpVecCat(..), allThePrimOps, primOpType, primOpSig, primOpTag, maxPrimOpTag, primOpOcc, @@ -25,6 +25,7 @@ module PrimOp ( import TysPrim import TysWiredIn +import CmmType import Demand import Var ( TyVar ) import OccName ( OccName, pprOccName, mkVarOccFS ) @@ -64,6 +65,7 @@ primOpTag op = iBox (tagOf_PrimOp op) -- supplies -- tagOf_PrimOp :: PrimOp -> FastInt #include "primop-tag.hs-incl" +tagOf_PrimOp _ = error "tagOf_PrimOp: unknown primop" instance Eq PrimOp where @@ -82,6 +84,12 @@ instance Outputable PrimOp where ppr op = pprPrimOp op \end{code} +\begin{code} +data PrimOpVecCat = IntVec + | WordVec + | FloatVec +\end{code} + An @Enum@-derived list would be better; meanwhile... (ToDo) \begin{code} @@ -173,6 +181,7 @@ else, notably a type, can be constructed) for each @PrimOp@. \begin{code} primOpInfo :: PrimOp -> PrimOpInfo #include "primop-primop-info.hs-incl" +primOpInfo _ = error "primOpInfo: unknown primop" \end{code} Here are a load of comments from the old primOp info: diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index f166065b22..b17f1a6f9a 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -76,11 +76,8 @@ module TysPrim( -- * Any anyTy, anyTyCon, anyTypeOfKind, - -- * SIMD - floatX4PrimTyCon, floatX4PrimTy, - doubleX2PrimTyCon, doubleX2PrimTy, - int32X4PrimTyCon, int32X4PrimTy, - int64X2PrimTyCon, int64X2PrimTy + -- * SIMD +#include "primop-vector-tys-exports.hs-incl" ) where #include "HsVersions.h" @@ -144,10 +141,7 @@ primTyCons , superKindTyCon , anyKindTyCon - , floatX4PrimTyCon - , doubleX2PrimTyCon - , int32X4PrimTyCon - , int64X2PrimTyCon +#include "primop-vector-tycons.hs-incl" ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -157,7 +151,7 @@ mkPrimTc fs unique tycon (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -186,10 +180,6 @@ stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyC bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon -floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon -doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon -int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon -int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon \end{code} %************************************************************************ @@ -766,28 +756,10 @@ anyTypeOfKind kind = TyConApp anyTyCon [kind] %************************************************************************ %* * -\subsection{SIMD vector type} +\subsection{SIMD vector types} %* * %************************************************************************ \begin{code} -floatX4PrimTy :: Type -floatX4PrimTy = mkTyConTy floatX4PrimTyCon -floatX4PrimTyCon :: TyCon -floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep) - -doubleX2PrimTy :: Type -doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon -doubleX2PrimTyCon :: TyCon -doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep) - -int32X4PrimTy :: Type -int32X4PrimTy = mkTyConTy int32X4PrimTyCon -int32X4PrimTyCon :: TyCon -int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep) - -int64X2PrimTy :: Type -int64X2PrimTy = mkTyConTy int64X2PrimTyCon -int64X2PrimTyCon :: TyCon -int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep) +#include "primop-vector-tys.hs-incl" \end{code} diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp index cfd6afa4c6..f4b7b6c5d0 100644 --- a/compiler/prelude/primops.txt.pp +++ b/compiler/prelude/primops.txt.pp @@ -39,6 +39,22 @@ -- (eg, out_of_line), whilst avoiding parsing complex expressions -- needed for strictness info. +-- The vector attribute is rather special. It takes a list of 3-tuples, each of +-- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of +-- the elements in the vector; LENGTH is the length of the vector; and +-- SCALAR_TYPE is the scalar type used to inject to/project from vector +-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example, +-- to broadcast a scalar value to a vector whose elements are of type Int8, we +-- use an Int#. + +-- When a primtype or primop has a vector attribute, it is instantiated at each +-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to +-- define a family of types or primops. Vector support also adds three new +-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types +-- derived from the 3-tuple. For the 3-tuple <Int64,INT64,2>, VECTOR expands to +-- Int64X2#, SCALAR expands to INT64, and VECTUPLE expands to (# INT64, INT64 +-- #). + defaults has_side_effects = False out_of_line = False -- See Note Note [PrimOp can_fail and has_side_effects] in PrimOp @@ -48,6 +64,7 @@ defaults strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity topDmd) topRes) } fixity = Nothing llvm_only = False + vector = [] -- Currently, documentation is produced using latex, so contents of -- description fields should be legal latex. Descriptions can contain @@ -2373,479 +2390,194 @@ primclass Coercible a b } ------------------------------------------------------------------------ -section "Float SIMD Vectors" - {Operations on SIMD vectors of 4 single-precision (32-bit) - floating-point numbers.} +section "SIMD Vectors" + {Operations on SIMD vectors.} ------------------------------------------------------------------------ -primtype FloatX4# - with llvm_only = True +#define ALL_VECTOR_TYPES \ + [<Int32,INT32,4>,<Int64,INT64,2> \ + ,<Word32,WORD32,4>,<Word64,WORD64,2> \ + ,<Float,Float#,4>,<Double,Double#,2>] -primop FloatToFloatX4Op "floatToFloatX4#" GenPrimOp - Float# -> FloatX4# - with llvm_only = True +#define SIGNED_VECTOR_TYPES \ + [<Int32,INT32,4>,<Int64,INT64,2> \ + ,<Float,Float#,4>,<Double,Double#,2>] -primop FloatX4PackOp "packFloatX4#" GenPrimOp - Float# -> Float# -> Float# -> Float# -> FloatX4# - with llvm_only = True +#define FLOAT_VECTOR_TYPES \ + [<Float,Float#,4>,<Double,Double#,2>] -primop FloatX4UnpackOp "unpackFloatX4#" GenPrimOp - FloatX4# -> (# Float#, Float#, Float#, Float# #) - with llvm_only = True +#define INT_VECTOR_TYPES \ + [<Int32,INT32,4>,<Int64,INT64,2> \ + ,<Word32,WORD32,4>,<Word64,WORD64,2>] -primop FloatX4InsertOp "insertFloatX4#" GenPrimOp - FloatX4# -> Float# -> Int# -> FloatX4# - with can_fail = True - llvm_only = True - -primop FloatX4AddOp "plusFloatX4#" Dyadic - FloatX4# -> FloatX4# -> FloatX4# - with commutable = True - llvm_only = True - -primop FloatX4SubOp "minusFloatX4#" Dyadic - FloatX4# -> FloatX4# -> FloatX4# +primtype VECTOR with llvm_only = True + vector = ALL_VECTOR_TYPES -primop FloatX4MulOp "timesFloatX4#" Dyadic - FloatX4# -> FloatX4# -> FloatX4# - with commutable = True - llvm_only = True - -primop FloatX4DivOp "divideFloatX4#" Dyadic - FloatX4# -> FloatX4# -> FloatX4# - with can_fail = True - llvm_only = True - -primop FloatX4NegOp "negateFloatX4#" Monadic - FloatX4# -> FloatX4# +primop VecBroadcastOp "broadcast#" GenPrimOp + SCALAR -> VECTOR + { Broadcast a scalar to all elements of a vector. } with llvm_only = True + vector = ALL_VECTOR_TYPES -primop IndexByteArrayOp_FloatX4 "indexFloatX4Array#" GenPrimOp - ByteArray# -> Int# -> FloatX4# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_FloatX4 "readFloatX4Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, FloatX4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_FloatX4 "writeFloatX4Array#" GenPrimOp - MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_FloatX4 "indexFloatX4OffAddr#" GenPrimOp - Addr# -> Int# -> FloatX4# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_FloatX4 "readFloatX4OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, FloatX4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteOffAddrOp_FloatX4 "writeFloatX4OffAddr#" GenPrimOp - Addr# -> Int# -> FloatX4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexByteArrayOp_FloatAsFloatX4 "indexFloatArrayAsFloatX4#" GenPrimOp - ByteArray# -> Int# -> FloatX4# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_FloatAsFloatX4 "readFloatArrayAsFloatX4#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, FloatX4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_FloatAsFloatX4 "writeFloatArrayAsFloatX4#" GenPrimOp - MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_FloatAsFloatX4 "indexFloatOffAddrAsFloatX4#" GenPrimOp - Addr# -> Int# -> FloatX4# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_FloatAsFloatX4 "readFloatOffAddrAsFloatX4#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, FloatX4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteOffAddrOp_FloatAsFloatX4 "writeFloatOffAddrAsFloatX4#" GenPrimOp - Addr# -> Int# -> FloatX4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - ------------------------------------------------------------------------- -section "Double SIMD Vectors" - {Operations on SIMD vectors of 2 double-precision (64-bit) - floating-point numbers.} ------------------------------------------------------------------------- - -primtype DoubleX2# +primop VecPackOp "pack#" GenPrimOp + VECTUPLE -> VECTOR + { Pack the elements of an unboxed tuple into a vector. } with llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleToDoubleX2Op "doubleToDoubleX2#" GenPrimOp - Double# -> DoubleX2# +primop VecUnpackOp "unpack#" GenPrimOp + VECTOR -> VECTUPLE + { Unpack the elements of a vector into an unboxed tuple. #} with llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleX2InsertOp "insertDoubleX2#" GenPrimOp - DoubleX2# -> Double# -> Int# -> DoubleX2# +primop VecInsertOp "insert#" GenPrimOp + VECTOR -> SCALAR -> Int# -> VECTOR + { Insert a scalar at the given position in a vector. } with can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleX2PackOp "packDoubleX2#" GenPrimOp - Double# -> Double# -> DoubleX2# - with llvm_only = True - -primop DoubleX2UnpackOp "unpackDoubleX2#" GenPrimOp - DoubleX2# -> (# Double#, Double# #) - with llvm_only = True - -primop DoubleX2AddOp "plusDoubleX2#" Dyadic - DoubleX2# -> DoubleX2# -> DoubleX2# +primop VecAddOp "plus#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Add two vectors element-wise. } with commutable = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleX2SubOp "minusDoubleX2#" Dyadic - DoubleX2# -> DoubleX2# -> DoubleX2# +primop VecSubOp "minus#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Subtract two vectors element-wise. } with llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleX2MulOp "timesDoubleX2#" Dyadic - DoubleX2# -> DoubleX2# -> DoubleX2# +primop VecMulOp "times#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Multiply two vectors element-wise. } with commutable = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop DoubleX2DivOp "divideDoubleX2#" Dyadic - DoubleX2# -> DoubleX2# -> DoubleX2# - with can_fail = True - llvm_only = True - -primop DoubleX2NegOp "negateDoubleX2#" Monadic - DoubleX2# -> DoubleX2# - with llvm_only = True - -primop IndexByteArrayOp_DoubleX2 "indexDoubleX2Array#" GenPrimOp - ByteArray# -> Int# -> DoubleX2# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_DoubleX2 "readDoubleX2Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, DoubleX2# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_DoubleX2 "writeDoubleX2Array#" GenPrimOp - MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_DoubleX2 "indexDoubleX2OffAddr#" GenPrimOp - Addr# -> Int# -> DoubleX2# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_DoubleX2 "readDoubleX2OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, DoubleX2# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteOffAddrOp_DoubleX2 "writeDoubleX2OffAddr#" GenPrimOp - Addr# -> Int# -> DoubleX2# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexByteArrayOp_DoubleAsDoubleX2 "indexDoubleArrayAsDoubleX2#" GenPrimOp - ByteArray# -> Int# -> DoubleX2# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_DoubleAsDoubleX2 "readDoubleArrayAsDoubleX2#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, DoubleX2# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_DoubleAsDoubleX2 "writeDoubleArrayAsDoubleX2#" GenPrimOp - MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_DoubleAsDoubleX2 "indexDoubleOffAddrAsDoubleX2#" GenPrimOp - Addr# -> Int# -> DoubleX2# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_DoubleAsDoubleX2 "readDoubleOffAddrAsDoubleX2#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, DoubleX2# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteOffAddrOp_DoubleAsDoubleX2 "writeDoubleOffAddrAsDoubleX2#" GenPrimOp - Addr# -> Int# -> DoubleX2# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - ------------------------------------------------------------------------- -section "Int32 SIMD Vectors" - {Operations on SIMD vectors of 4 32-bit signed integers.} ------------------------------------------------------------------------- - -primtype Int32X4# - with llvm_only = True - -primop Int32ToInt32X4Op "int32ToInt32X4#" GenPrimOp - INT32 -> Int32X4# - with llvm_only = True - -primop Int32X4InsertOp "insertInt32X4#" GenPrimOp - Int32X4# -> INT32 -> Int# -> Int32X4# +primop VecDivOp "divide#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Divide two vectors element-wise. } with can_fail = True llvm_only = True + vector = FLOAT_VECTOR_TYPES -primop Int32X4PackOp "packInt32X4#" GenPrimOp - INT32 -> INT32 -> INT32 -> INT32 -> Int32X4# - with llvm_only = True - -primop Int32X4UnpackOp "unpackInt32X4#" GenPrimOp - Int32X4# -> (# INT32, INT32, INT32, INT32 #) - with llvm_only = True - -primop Int32X4AddOp "plusInt32X4#" Dyadic - Int32X4# -> Int32X4# -> Int32X4# - with commutable = True - llvm_only = True - -primop Int32X4SubOp "minusInt32X4#" Dyadic - Int32X4# -> Int32X4# -> Int32X4# - with llvm_only = True - -primop Int32X4MulOp "timesInt32X4#" Dyadic - Int32X4# -> Int32X4# -> Int32X4# - with commutable = True - llvm_only = True - -primop Int32X4QuotOp "quotInt32X4#" Dyadic - Int32X4# -> Int32X4# -> Int32X4# +primop VecQuotOp "quot#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Rounds towards zero element-wise. } with can_fail = True llvm_only = True + vector = INT_VECTOR_TYPES -primop Int32X4RemOp "remInt32X4#" Dyadic - Int32X4# -> Int32X4# -> Int32X4# +primop VecRemOp "rem#" Dyadic + VECTOR -> VECTOR -> VECTOR + { Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. } with can_fail = True llvm_only = True + vector = INT_VECTOR_TYPES -primop Int32X4NegOp "negateInt32X4#" Monadic - Int32X4# -> Int32X4# +primop VecNegOp "negate#" Monadic + VECTOR -> VECTOR + { Negate element-wise. } with llvm_only = True + vector = SIGNED_VECTOR_TYPES -primop IndexByteArrayOp_Int32X4 "indexInt32X4Array#" GenPrimOp - ByteArray# -> Int# -> Int32X4# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_Int32X4 "readInt32X4Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32X4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_Int32X4 "writeInt32X4Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_Int32X4 "indexInt32X4OffAddr#" GenPrimOp - Addr# -> Int# -> Int32X4# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_Int32X4 "readInt32X4OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int32X4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteOffAddrOp_Int32X4 "writeInt32X4OffAddr#" GenPrimOp - Addr# -> Int# -> Int32X4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexByteArrayOp_Int32AsInt32X4 "indexInt32ArrayAsInt32X4#" GenPrimOp - ByteArray# -> Int# -> Int32X4# - with can_fail = True - llvm_only = True - -primop ReadByteArrayOp_Int32AsInt32X4 "readInt32ArrayAsInt32X4#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32X4# #) - with has_side_effects = True - can_fail = True - llvm_only = True - -primop WriteByteArrayOp_Int32AsInt32X4 "writeInt32ArrayAsInt32X4#" GenPrimOp - MutableByteArray# s -> Int# -> Int32X4# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True - -primop IndexOffAddrOp_Int32AsInt32X4 "indexInt32OffAddrAsInt32X4#" GenPrimOp - Addr# -> Int# -> Int32X4# +primop VecIndexByteArrayOp "indexArray#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array. } with can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop ReadOffAddrOp_Int32AsInt32X4 "readInt32OffAddrAsInt32X4#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int32X4# #) +primop VecReadByteArrayOp "readArray#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop WriteOffAddrOp_Int32AsInt32X4 "writeInt32OffAddrAsInt32X4#" GenPrimOp - Addr# -> Int# -> Int32X4# -> State# s -> State# s +primop VecWriteByteArrayOp "writeArray#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES ------------------------------------------------------------------------- -section "Int64 SIMD Vectors" - {Operations on SIMD vectors of 2 64-bit signed integers.} ------------------------------------------------------------------------- - -primtype Int64X2# - with llvm_only = True - -primop Int64ToInt64X2Op "int64ToInt64X2#" GenPrimOp - INT64 -> Int64X2# - with llvm_only = True - -primop Int64X2InsertOp "insertInt64X2#" GenPrimOp - Int64X2# -> INT64 -> Int# -> Int64X2# - with can_fail = True - llvm_only = True - -primop Int64X2PackOp "packInt64X2#" GenPrimOp - INT64 -> INT64 -> Int64X2# - with llvm_only = True - -primop Int64X2UnpackOp "unpackInt64X2#" GenPrimOp - Int64X2# -> (# INT64, INT64 #) - with llvm_only = True - -primop Int64X2AddOp "plusInt64X2#" Dyadic - Int64X2# -> Int64X2# -> Int64X2# - with commutable = True - llvm_only = True - -primop Int64X2SubOp "minusInt64X2#" Dyadic - Int64X2# -> Int64X2# -> Int64X2# - with llvm_only = True - -primop Int64X2MulOp "timesInt64X2#" Dyadic - Int64X2# -> Int64X2# -> Int64X2# - with commutable = True - llvm_only = True - -primop Int64X2QuotOp "quotInt64X2#" Dyadic - Int64X2# -> Int64X2# -> Int64X2# - with can_fail = True - llvm_only = True - -primop Int64X2RemOp "remInt64X2#" Dyadic - Int64X2# -> Int64X2# -> Int64X2# - with can_fail = True - llvm_only = True - -primop Int64X2NegOp "negateInt64X2#" Monadic - Int64X2# -> Int64X2# - with llvm_only = True - -primop IndexByteArrayOp_Int64X2 "indexInt64X2Array#" GenPrimOp - ByteArray# -> Int# -> Int64X2# +primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in bytes. } with can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop ReadByteArrayOp_Int64X2 "readInt64X2Array#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64X2# #) +primop VecReadOffAddrOp "readOffAddr#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in bytes. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop WriteByteArrayOp_Int64X2 "writeInt64X2Array#" GenPrimOp - MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s +primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in bytes. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop IndexOffAddrOp_Int64X2 "indexInt64X2OffAddr#" GenPrimOp - Addr# -> Int# -> Int64X2# - with can_fail = True - llvm_only = True - -primop ReadOffAddrOp_Int64X2 "readInt64X2OffAddr#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int64X2# #) - with has_side_effects = True - llvm_only = True - -primop WriteOffAddrOp_Int64X2 "writeInt64X2OffAddr#" GenPrimOp - Addr# -> Int# -> Int64X2# -> State# s -> State# s - with has_side_effects = True - can_fail = True - llvm_only = True -primop IndexByteArrayOp_Int64AsInt64X2 "indexInt64ArrayAsInt64X2#" GenPrimOp - ByteArray# -> Int# -> Int64X2# +primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp + ByteArray# -> Int# -> VECTOR + { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. } with can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop ReadByteArrayOp_Int64AsInt64X2 "readInt64ArrayAsInt64X2#" GenPrimOp - MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64X2# #) +primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #) + { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop WriteByteArrayOp_Int64AsInt64X2 "writeInt64ArrayAsInt64X2#" GenPrimOp - MutableByteArray# s -> Int# -> Int64X2# -> State# s -> State# s +primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp + MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s + { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop IndexOffAddrOp_Int64AsInt64X2 "indexInt64OffAddrAsInt64X2#" GenPrimOp - Addr# -> Int# -> Int64X2# +primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR + { Reads vector; offset in scalar elements. } with can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop ReadOffAddrOp_Int64AsInt64X2 "readInt64OffAddrAsInt64X2#" GenPrimOp - Addr# -> Int# -> State# s -> (# State# s, Int64X2# #) +primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp + Addr# -> Int# -> State# s -> (# State# s, VECTOR #) + { Reads vector; offset in scalar elements. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES -primop WriteOffAddrOp_Int64AsInt64X2 "writeInt64OffAddrAsInt64X2#" GenPrimOp - Addr# -> Int# -> Int64X2# -> State# s -> State# s +primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp + Addr# -> Int# -> VECTOR -> State# s -> State# s + { Write vector; offset in scalar elements. } with has_side_effects = True can_fail = True llvm_only = True + vector = ALL_VECTOR_TYPES ------------------------------------------------------------------------ section "Prefetch" diff --git a/utils/genprimopcode/Lexer.x b/utils/genprimopcode/Lexer.x index ff18e17373..d29d8a17f0 100644 --- a/utils/genprimopcode/Lexer.x +++ b/utils/genprimopcode/Lexer.x @@ -40,6 +40,10 @@ words :- <0> ")" { mkT TCloseParen } <0> "(#" { mkT TOpenParenHash } <0> "#)" { mkT THashCloseParen } + <0> "[" { mkT TOpenBracket } + <0> "]" { mkT TCloseBracket } + <0> "<" { mkT TOpenAngle } + <0> ">" { mkT TCloseAngle } <0> "section" { mkT TSection } <0> "primop" { mkT TPrimop } <0> "pseudoop" { mkT TPseudoop } @@ -58,7 +62,11 @@ words :- <0> "infixl" { mkT TInfixL } <0> "infixr" { mkT TInfixR } <0> "Nothing" { mkT TNothing } + <0> "vector" { mkT TVector } <0> "thats_all_folks" { mkT TThatsAllFolks } + <0> "SCALAR" { mkT TSCALAR } + <0> "VECTOR" { mkT TVECTOR } + <0> "VECTUPLE" { mkT TVECTUPLE } <0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName } <0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName } <0> [0-9][0-9]* { mkTv (TInteger . read) } diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index a9f6a2a5fd..8b97ca169c 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -13,6 +13,100 @@ import Data.List import Data.Maybe ( catMaybes ) import System.Environment ( getArgs ) +vecOptions :: Entry -> [(String,String,Int)] +vecOptions i = + concat [vecs | OptionVector vecs <- opts i] + +desugarVectorSpec :: Entry -> [Entry] +desugarVectorSpec i@(Section {}) = [i] +desugarVectorSpec i = case vecOptions i of + [] -> [i] + vos -> map genVecEntry vos + where + genVecEntry :: (String,String,Int) -> Entry + genVecEntry (con,repCon,n) = + case i of + PrimOpSpec {} -> + PrimVecOpSpec { cons = "(" ++ concat (intersperse " " [cons i, vecCat, show n, vecWidth]) ++ ")" + , name = name' + , prefix = pfx + , veclen = n + , elemrep = con ++ "ElemRep" + , ty = desugarTy (ty i) + , cat = cat i + , desc = desc i + , opts = opts i + } + PrimTypeSpec {} -> + PrimVecTypeSpec { ty = desugarTy (ty i) + , prefix = pfx + , veclen = n + , elemrep = con ++ "ElemRep" + , desc = desc i + , opts = opts i + } + _ -> + error "vector options can only be given for primops and primtypes" + where + vecCons = con++"X"++show n++"#" + vecCat = conCat con + vecWidth = conWidth con + pfx = lowerHead con++"X"++show n + vecTyName = pfx++"PrimTy" + + name' | Just pre <- splitSuffix (name i) "Array#" = pre++vec++"Array#" + | Just pre <- splitSuffix (name i) "OffAddr#" = pre++vec++"OffAddr#" + | Just pre <- splitSuffix (name i) "ArrayAs#" = pre++con++"ArrayAs"++vec++"#" + | Just pre <- splitSuffix (name i) "OffAddrAs#" = pre++con++"OffAddrAs"++vec++"#" + | otherwise = init (name i)++vec ++"#" + where + vec = con++"X"++show n + + splitSuffix :: Eq a => [a] -> [a] -> Maybe [a] + splitSuffix s suf + | drop len s == suf = Just (take len s) + | otherwise = Nothing + where + len = length s - length suf + + lowerHead s = toLower (head s) : tail s + + desugarTy :: Ty -> Ty + desugarTy (TyF s d) = TyF (desugarTy s) (desugarTy d) + desugarTy (TyC s d) = TyC (desugarTy s) (desugarTy d) + desugarTy (TyApp SCALAR []) = TyApp (TyCon repCon) [] + desugarTy (TyApp VECTOR []) = TyApp (VecTyCon vecCons vecTyName) [] + desugarTy (TyApp VECTUPLE []) = TyUTup (replicate n (TyApp (TyCon repCon) [])) + desugarTy (TyApp tycon ts) = TyApp tycon (map desugarTy ts) + desugarTy t@(TyVar {}) = t + desugarTy (TyUTup ts) = TyUTup (map desugarTy ts) + + conCat :: String -> String + conCat "Int8" = "IntVec" + conCat "Int16" = "IntVec" + conCat "Int32" = "IntVec" + conCat "Int64" = "IntVec" + conCat "Word8" = "WordVec" + conCat "Word16" = "WordVec" + conCat "Word32" = "WordVec" + conCat "Word64" = "WordVec" + conCat "Float" = "FloatVec" + conCat "Double" = "FloatVec" + conCat con = error $ "conCat: unknown type constructor " ++ con ++ "\n" + + conWidth :: String -> String + conWidth "Int8" = "W8" + conWidth "Int16" = "W16" + conWidth "Int32" = "W32" + conWidth "Int64" = "W64" + conWidth "Word8" = "W8" + conWidth "Word16" = "W16" + conWidth "Word32" = "W32" + conWidth "Word64" = "W64" + conWidth "Float" = "W32" + conWidth "Double" = "W64" + conWidth con = error $ "conWidth: unknown type constructor " ++ con ++ "\n" + main :: IO () main = getArgs >>= \args -> if length args /= 1 || head args `notElem` known_args @@ -75,6 +169,18 @@ main = getArgs >>= \args -> "--primop-list" -> putStr (gen_primop_list p_o_specs) + "--primop-vector-uniques" + -> putStr (gen_primop_vector_uniques p_o_specs) + + "--primop-vector-tys" + -> putStr (gen_primop_vector_tys p_o_specs) + + "--primop-vector-tys-exports" + -> putStr (gen_primop_vector_tys_exports p_o_specs) + + "--primop-vector-tycons" + -> putStr (gen_primop_vector_tycons p_o_specs) + "--make-haskell-wrappers" -> putStr (gen_wrappers p_o_specs) @@ -103,6 +209,10 @@ known_args "--primop-primop-info", "--primop-tag", "--primop-list", + "--primop-vector-uniques", + "--primop-vector-tys", + "--primop-vector-tys-exports", + "--primop-vector-tycons", "--make-haskell-wrappers", "--make-haskell-source", "--make-ext-core-source", @@ -136,32 +246,40 @@ gen_hs_source (Info defaults entries) = ++ "-----------------------------------------------------------------------------\n" ++ "{-# LANGUAGE MultiParamTypeClasses #-}\n" ++ "module GHC.Prim (\n" - ++ unlines (map (("\t" ++) . hdr) entries) + ++ unlines (map (("\t" ++) . hdr) entries') ++ ") where\n" ++ "\n" ++ "{-\n" ++ unlines (map opt defaults) ++ "-}\n" - ++ unlines (concatMap ent entries) ++ "\n\n\n" - where opt (OptionFalse n) = n ++ " = False" + ++ unlines (concatMap ent entries') ++ "\n\n\n" + where entries' = concatMap desugarVectorSpec entries + + opt (OptionFalse n) = n ++ " = False" opt (OptionTrue n) = n ++ " = True" opt (OptionString n v) = n ++ " = { " ++ v ++ "}" opt (OptionInteger n v) = n ++ " = " ++ show v + opt (OptionVector _) = "" opt (OptionFixity mf) = "fixity" ++ " = " ++ show mf - hdr s@(Section {}) = sec s - hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," - hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," - hdr (PrimTypeSpec { ty = TyApp n _ }) = wrapTy n ++ "," - hdr (PrimTypeSpec {}) = error "Illegal type spec" - hdr (PrimClassSpec { cls = TyApp n _ }) = wrapTy n ++ "," - hdr (PrimClassSpec {}) = error "Illegal class spec" - - ent (Section {}) = [] - ent o@(PrimOpSpec {}) = spec o - ent o@(PrimTypeSpec {}) = spec o - ent o@(PrimClassSpec {}) = spec o - ent o@(PseudoOpSpec {}) = spec o + hdr s@(Section {}) = sec s + hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimVecOpSpec { name = n }) = wrapOp n ++ "," + hdr (PseudoOpSpec { name = n }) = wrapOp n ++ "," + hdr (PrimTypeSpec { ty = TyApp (TyCon n) _ }) = wrapTy n ++ "," + hdr (PrimTypeSpec {}) = error $ "Illegal type spec" + hdr (PrimClassSpec { cls = TyApp (TyCon n) _ }) = wrapTy n ++ "," + hdr (PrimClassSpec {}) = error "Illegal class spec" + hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapTy n ++ "," + hdr (PrimVecTypeSpec {}) = error $ "Illegal type spec" + + ent (Section {}) = [] + ent o@(PrimOpSpec {}) = spec o + ent o@(PrimVecOpSpec {}) = spec o + ent o@(PrimTypeSpec {}) = spec o + ent o@(PrimClassSpec {}) = spec o + ent o@(PrimVecTypeSpec {}) = spec o + ent o@(PseudoOpSpec {}) = spec o sec s = "\n-- * " ++ escape (title s) ++ "\n" ++ (unlines $ map ("-- " ++ ) $ lines $ unlatex $ escape $ "|" ++ desc s) ++ "\n" @@ -173,6 +291,11 @@ gen_hs_source (Info defaults entries) = ++ [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] + PrimVecOpSpec { name = n, ty = t, opts = options } -> + [ pprFixity fixity n | OptionFixity (Just fixity) <- options ] + ++ + [ wrapOp n ++ " :: " ++ pprTy t, + wrapOp n ++ " = let x = x in x" ] PseudoOpSpec { name = n, ty = t } -> [ wrapOp n ++ " :: " ++ pprTy t, wrapOp n ++ " = let x = x in x" ] @@ -180,6 +303,8 @@ gen_hs_source (Info defaults entries) = [ "data " ++ pprTy t ] PrimClassSpec { cls = t } -> [ "class " ++ pprTy t ] + PrimVecTypeSpec { ty = t } -> + [ "data " ++ pprTy t ] Section { } -> [] comm = case (desc o) of @@ -212,7 +337,7 @@ pprTy = pty pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = tc ++ concat (map (' ' :) (map paty ts)) + pbty (TyApp tc ts) = show tc ++ concat (map (' ' :) (map paty ts)) pbty (TyUTup ts) = "(# " ++ concat (intersperse "," (map pty ts)) ++ " #)" @@ -259,7 +384,7 @@ gen_ext_core_source entries = where printList f = concat . intersperse ",\n" . filter (not . null) . map f tcEnt (PrimTypeSpec {ty=t}) = case t of - TyApp tc args -> parens tc (tcKind tc args) + TyApp tc args -> parens (show tc) (tcKind tc args) _ -> error ("tcEnt: type in PrimTypeSpec is not a type" ++ " constructor: " ++ show t) tcEnt _ = "" @@ -270,12 +395,12 @@ gen_ext_core_source entries = -- alternative would be to refer to things indirectly and hard-wire -- certain things (e.g., the kind of the Any constructor, here) into -- ext-core's Prims module again. - tcKind "Any" _ = "Klifted" - tcKind tc [] | last tc == '#' = "Kunlifted" - tcKind _ [] | otherwise = "Klifted" + tcKind (TyCon "Any") _ = "Klifted" + tcKind tc [] | last (show tc) == '#' = "Kunlifted" + tcKind _ [] | otherwise = "Klifted" -- assumes that all type arguments are lifted (are they?) - tcKind tc (_v:as) = "(Karrow Klifted " ++ tcKind tc as - ++ ")" + tcKind tc (_v:as) = "(Karrow Klifted " ++ tcKind tc as + ++ ")" valEnt (PseudoOpSpec {name=n, ty=t}) = valEntry n t valEnt (PrimOpSpec {name=n, ty=t}) = valEntry n t valEnt _ = "" @@ -290,7 +415,7 @@ gen_ext_core_source entries = ++ " " ++ paren s1)) ++ " " ++ paren s2 mkTconApp tc args = foldl tapp tc args - mkTcon tc = paren $ "Tcon " ++ paren (qualify True tc) + mkTcon tc = paren $ "Tcon " ++ paren (qualify True (show tc)) mkUtupleTy args = foldl tapp (tcUTuple (length args)) args mkForallTy [] t = t mkForallTy vs t = foldr @@ -314,7 +439,7 @@ gen_ext_core_source entries = ++ show n ++ "H") tyEnt (PrimTypeSpec {ty=(TyApp tc _args)}) = " " ++ paren ("Tcon " ++ - (paren (qualify True tc))) + (paren (qualify True (show tc)))) tyEnt _ = "" -- more hacks. might be better to do this on the ext-core side, @@ -334,7 +459,7 @@ gen_ext_core_source entries = prefixes ps = filter (\ t -> case t of (PrimTypeSpec {ty=(TyApp tc _args)}) -> - any (\ p -> p `isPrefixOf` tc) ps + any (\ p -> p `isPrefixOf` show tc) ps _ -> False) parens n ty' = " (zEncodeString \"" ++ n ++ "\", " ++ ty' ++ ")" @@ -358,6 +483,8 @@ gen_latex_doc (Info defaults entries) ++ d ++ "}{" ++ mk_options o ++ "}\n" + mk_entry (PrimVecOpSpec {}) = + "" mk_entry (Section {title=ti,desc=d}) = "\\primopsection{" ++ latex_encode ti ++ "}{" @@ -376,6 +503,8 @@ gen_latex_doc (Info defaults entries) ++ d ++ "}{" ++ mk_options o ++ "}\n" + mk_entry (PrimVecTypeSpec {}) = + "" mk_entry (PseudoOpSpec {name=n,ty=t,desc=d,opts=o}) = "\\pseudoopspec{" ++ latex_encode (zencode n) ++ "}{" @@ -388,7 +517,7 @@ gen_latex_doc (Info defaults entries) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = tc ++ (concat (map (' ':) (map paty ts))) + pbty (TyApp tc ts) = show tc ++ (concat (map (' ':) (map paty ts))) pbty (TyUTup ts) = "(# " ++ (concat (intersperse "," (map pty ts))) ++ " #)" pbty t = paty t paty (TyVar tv) = tv @@ -398,11 +527,11 @@ gen_latex_doc (Info defaults entries) where pty (TyF t1 t2) = pbty t1 ++ " -> " ++ pty t2 pty (TyC t1 t2) = pbty t1 ++ " => " ++ pty t2 pty t = pbty t - pbty (TyApp tc ts) = (zencode tc) ++ (concat (map (' ':) (map paty ts))) + pbty (TyApp tc ts) = (zencode (show tc)) ++ (concat (map (' ':) (map paty ts))) pbty (TyUTup ts) = (zencode (utuplenm (length ts))) ++ (concat ((map (' ':) (map paty ts)))) pbty t = paty t paty (TyVar tv) = zencode tv - paty (TyApp tc []) = zencode tc + paty (TyApp tc []) = zencode (show tc) paty t = "(" ++ pty t ++ ")" utuplenm 1 = "(# #)" utuplenm n = "(#" ++ (replicate (n-1) ',') ++ "#)" @@ -441,6 +570,7 @@ gen_latex_doc (Info defaults entries) Just (OptionString _ _) -> error "String value for boolean option" Just (OptionInteger _ _) -> error "Integer value for boolean option" Just (OptionFixity _) -> error "Fixity value for boolean option" + Just (OptionVector _) -> error "vector template for boolean option" Nothing -> "" mk_strictness o = @@ -532,8 +662,8 @@ gen_wrappers (Info _ entries) filter (not.is_llvm_only) $ filter is_primop entries tycons = foldr union [] $ map (tyconsIn . ty) specs - tycons' = filter (`notElem` ["()", "Bool"]) tycons - types = concat $ intersperse ", " tycons' + tycons' = filter (`notElem` [TyCon "()", TyCon "Bool"]) tycons + types = concat $ intersperse ", " $ map show tycons' f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) lhs = src_name ++ " " ++ unwords args @@ -568,24 +698,99 @@ gen_primop_list (Info _ entries) map (\p -> " , " ++ cons p) rest ++ [ " ]" ] - ) where (first:rest) = filter is_primop entries + ) where (first:rest) = concatMap desugarVectorSpec (filter is_primop entries) + +mIN_VECTOR_UNIQUE :: Int +mIN_VECTOR_UNIQUE = 300 + +gen_primop_vector_uniques :: Info -> String +gen_primop_vector_uniques (Info _ entries) + = unlines $ + concatMap mkVecUnique (specs `zip` [mIN_VECTOR_UNIQUE..]) + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecUnique :: (Entry, Int) -> [String] + mkVecUnique (i, unique) = + [ key_id ++ " :: Unique" + , key_id ++ " = mkPreludeTyConUnique " ++ show unique + ] + where + key_id = prefix i ++ "PrimTyConKey" + +gen_primop_vector_tys :: Info -> String +gen_primop_vector_tys (Info _ entries) + = unlines $ + concatMap mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> [String] + mkVecTypes i = + [ name_id ++ " :: Name" + , name_id ++ " = mkPrimTc (fsLit \"" ++ pprTy (ty i) ++ "\") " ++ key_id ++ " " ++ tycon_id + , ty_id ++ " :: Type" + , ty_id ++ " = mkTyConTy " ++ tycon_id + , tycon_id ++ " :: TyCon" + , tycon_id ++ " = pcPrimTyCon0 " ++ name_id ++ + " (VecRep " ++ show (veclen i) ++ " " ++ elemrep i ++ ")" + ] + where + key_id = prefix i ++ "PrimTyConKey" + name_id = prefix i ++ "PrimTyConName" + ty_id = prefix i ++ "PrimTy" + tycon_id = prefix i ++ "PrimTyCon" + +gen_primop_vector_tys_exports :: Info -> String +gen_primop_vector_tys_exports (Info _ entries) + = unlines $ + map mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> String + mkVecTypes i = + "\t" ++ ty_id ++ ", " ++ tycon_id ++ "," + where + ty_id = prefix i ++ "PrimTy" + tycon_id = prefix i ++ "PrimTyCon" + +gen_primop_vector_tycons :: Info -> String +gen_primop_vector_tycons (Info _ entries) + = unlines $ + map mkVecTypes specs + where + specs = concatMap desugarVectorSpec (filter is_vector (filter is_primtype entries)) + + mkVecTypes :: Entry -> String + mkVecTypes i = + " , " ++ tycon_id + where + tycon_id = prefix i ++ "PrimTyCon" gen_primop_tag :: Info -> String gen_primop_tag (Info _ entries) = unlines (max_def_type : max_def : tagOf_type : zipWith f primop_entries [1 :: Int ..]) where - primop_entries = filter is_primop entries + primop_entries = concatMap desugarVectorSpec $ filter is_primop entries tagOf_type = "tagOf_PrimOp :: PrimOp -> FastInt" f i n = "tagOf_PrimOp " ++ cons i ++ " = _ILIT(" ++ show n ++ ")" max_def_type = "maxPrimOpTag :: Int" max_def = "maxPrimOpTag = " ++ show (length primop_entries) gen_data_decl :: Info -> String -gen_data_decl (Info _ entries) - = let conss = map cons (filter is_primop entries) - in "data PrimOp\n = " ++ head conss ++ "\n" - ++ unlines (map (" | "++) (tail conss)) +gen_data_decl (Info _ entries) = + "data PrimOp\n = " ++ head conss ++ "\n" + ++ unlines (map (" | "++) (tail conss)) + where + conss = map genCons (filter is_primop entries) + + genCons :: Entry -> String + genCons entry = + case vecOptions entry of + [] -> cons entry + _ -> cons entry ++ " PrimOpVecCat Length Width" gen_switch_from_attribs :: String -> String -> Info -> String gen_switch_from_attribs attrib_name fn_name (Info defaults entries) @@ -596,12 +801,15 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) getAltRhs (OptionTrue _) = "True" getAltRhs (OptionInteger _ i) = show i getAltRhs (OptionString _ s) = s + getAltRhs (OptionVector _) = "True" getAltRhs (OptionFixity mf) = show mf mkAlt po = case lookup_attrib attrib_name (opts po) of Nothing -> Nothing - Just xx -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) + Just xx -> case vecOptions po of + [] -> Just (fn_name ++ " " ++ cons po ++ " = " ++ getAltRhs xx) + _ -> Just (fn_name ++ " (" ++ cons po ++ " _ _ _) = " ++ getAltRhs xx) in case defv of @@ -616,7 +824,7 @@ gen_switch_from_attribs attrib_name fn_name (Info defaults entries) gen_primop_info :: Info -> String gen_primop_info (Info _ entries) - = unlines (map mkPOItext (filter is_primop entries)) + = unlines (map mkPOItext (concatMap desugarVectorSpec (filter is_primop entries))) mkPOItext :: Entry -> String mkPOItext i = mkPOI_LHS_text i ++ mkPOI_RHS_text i @@ -664,29 +872,25 @@ ppTyVar "o" = "openAlphaTyVar" ppTyVar _ = error "Unknown type var" ppType :: Ty -> String -ppType (TyApp "Any" []) = "anyTy" -ppType (TyApp "Bool" []) = "boolTy" - -ppType (TyApp "Int#" []) = "intPrimTy" -ppType (TyApp "Int32#" []) = "int32PrimTy" -ppType (TyApp "Int64#" []) = "int64PrimTy" -ppType (TyApp "Char#" []) = "charPrimTy" -ppType (TyApp "Word#" []) = "wordPrimTy" -ppType (TyApp "Word32#" []) = "word32PrimTy" -ppType (TyApp "Word64#" []) = "word64PrimTy" -ppType (TyApp "Addr#" []) = "addrPrimTy" -ppType (TyApp "Float#" []) = "floatPrimTy" -ppType (TyApp "Double#" []) = "doublePrimTy" -ppType (TyApp "FloatX4#" []) = "floatX4PrimTy" -ppType (TyApp "DoubleX2#" []) = "doubleX2PrimTy" -ppType (TyApp "Int32X4#" []) = "int32X4PrimTy" -ppType (TyApp "Int64X2#" []) = "int64X2PrimTy" -ppType (TyApp "ByteArray#" []) = "byteArrayPrimTy" -ppType (TyApp "RealWorld" []) = "realWorldTy" -ppType (TyApp "ThreadId#" []) = "threadIdPrimTy" -ppType (TyApp "ForeignObj#" []) = "foreignObjPrimTy" -ppType (TyApp "BCO#" []) = "bcoPrimTy" -ppType (TyApp "()" []) = "unitTy" -- unitTy is TysWiredIn's name for () +ppType (TyApp (TyCon "Any") []) = "anyTy" +ppType (TyApp (TyCon "Bool") []) = "boolTy" + +ppType (TyApp (TyCon "Int#") []) = "intPrimTy" +ppType (TyApp (TyCon "Int32#") []) = "int32PrimTy" +ppType (TyApp (TyCon "Int64#") []) = "int64PrimTy" +ppType (TyApp (TyCon "Char#") []) = "charPrimTy" +ppType (TyApp (TyCon "Word#") []) = "wordPrimTy" +ppType (TyApp (TyCon "Word32#") []) = "word32PrimTy" +ppType (TyApp (TyCon "Word64#") []) = "word64PrimTy" +ppType (TyApp (TyCon "Addr#") []) = "addrPrimTy" +ppType (TyApp (TyCon "Float#") []) = "floatPrimTy" +ppType (TyApp (TyCon "Double#") []) = "doublePrimTy" +ppType (TyApp (TyCon "ByteArray#") []) = "byteArrayPrimTy" +ppType (TyApp (TyCon "RealWorld") []) = "realWorldTy" +ppType (TyApp (TyCon "ThreadId#") []) = "threadIdPrimTy" +ppType (TyApp (TyCon "ForeignObj#") []) = "foreignObjPrimTy" +ppType (TyApp (TyCon "BCO#") []) = "bcoPrimTy" +ppType (TyApp (TyCon "()") []) = "unitTy" -- unitTy is TysWiredIn's name for () ppType (TyVar "a") = "alphaTy" ppType (TyVar "b") = "betaTy" @@ -694,28 +898,31 @@ ppType (TyVar "c") = "gammaTy" ppType (TyVar "s") = "deltaTy" ppType (TyVar "o") = "openAlphaTy" -ppType (TyApp "State#" [x]) = "mkStatePrimTy " ++ ppType x -ppType (TyApp "MutVar#" [x,y]) = "mkMutVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyApp "MutableArray#" [x,y]) = "mkMutableArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x +ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "MutableArray#") [x,y]) = "mkMutableArrayPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "MutableArrayArray#") [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "MutableByteArray#") [x]) = "mkMutableByteArrayPrimTy " + ++ ppType x +ppType (TyApp (TyCon "Array#") [x]) = "mkArrayPrimTy " ++ ppType x +ppType (TyApp (TyCon "ArrayArray#") []) = "mkArrayArrayPrimTy" + + +ppType (TyApp (TyCon "Weak#") [x]) = "mkWeakPrimTy " ++ ppType x +ppType (TyApp (TyCon "StablePtr#") [x]) = "mkStablePtrPrimTy " ++ ppType x +ppType (TyApp (TyCon "StableName#") [x]) = "mkStableNamePrimTy " ++ ppType x + +ppType (TyApp (TyCon "MVar#") [x,y]) = "mkMVarPrimTy " ++ ppType x + ++ " " ++ ppType y +ppType (TyApp (TyCon "TVar#") [x,y]) = "mkTVarPrimTy " ++ ppType x ++ " " ++ ppType y -ppType (TyApp "MutableArrayArray#" [x]) = "mkMutableArrayArrayPrimTy " ++ ppType x -ppType (TyApp "MutableByteArray#" [x]) = "mkMutableByteArrayPrimTy " - ++ ppType x -ppType (TyApp "Array#" [x]) = "mkArrayPrimTy " ++ ppType x -ppType (TyApp "ArrayArray#" []) = "mkArrayArrayPrimTy" - - -ppType (TyApp "Weak#" [x]) = "mkWeakPrimTy " ++ ppType x -ppType (TyApp "StablePtr#" [x]) = "mkStablePtrPrimTy " ++ ppType x -ppType (TyApp "StableName#" [x]) = "mkStableNamePrimTy " ++ ppType x - -ppType (TyApp "MVar#" [x,y]) = "mkMVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyApp "TVar#" [x,y]) = "mkTVarPrimTy " ++ ppType x - ++ " " ++ ppType y -ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " - ++ listify (map ppType ts) ++ ")" + +ppType (TyApp (VecTyCon _ pptc) []) = pptc + +ppType (TyUTup ts) = "(mkTupleTy UnboxedTuple " + ++ listify (map ppType ts) ++ ")" ppType (TyF s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" ppType (TyC s d) = "(mkFunTy (" ++ ppType s ++ ") (" ++ ppType d ++ "))" diff --git a/utils/genprimopcode/Parser.y b/utils/genprimopcode/Parser.y index eb76cb0407..07ef03b986 100644 --- a/utils/genprimopcode/Parser.y +++ b/utils/genprimopcode/Parser.y @@ -32,6 +32,10 @@ import Syntax '#)' { THashCloseParen } '{' { TOpenBrace } '}' { TCloseBrace } + '[' { TOpenBracket } + ']' { TCloseBracket } + '<' { TOpenAngle } + '>' { TCloseAngle } section { TSection } primop { TPrimop } pseudoop { TPseudoop } @@ -50,6 +54,10 @@ import Syntax infixl { TInfixL } infixr { TInfixR } nothing { TNothing } + vector { TVector } + SCALAR { TSCALAR } + VECTOR { TVECTOR } + VECTUPLE { TVECTUPLE } thats_all_folks { TThatsAllFolks } lowerName { TLowerName $$ } upperName { TUpperName $$ } @@ -74,6 +82,7 @@ pOption : lowerName '=' false { OptionFalse $1 } | lowerName '=' true { OptionTrue $1 } | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } | lowerName '=' integer { OptionInteger $1 $3 } + | vector '=' pVectorTemplate { OptionVector $3 } | fixity '=' pInfix { OptionFixity $3 } pInfix :: { Maybe Fixity } @@ -147,6 +156,17 @@ pInside :: { String } pInside : '{' pInsides '}' { "{" ++ $2 ++ "}" } | noBraces { $1 } +pVectorTemplate :: { [(String, String, Int)] } +pVectorTemplate : '[' pVectors ']' { $2 } + +pVectors :: { [(String, String, Int)] } +pVectors : pVector ',' pVectors { [$1] ++ $3 } + | pVector { [$1] } + | {- empty -} { [] } + +pVector :: { (String, String, Int) } +pVector : '<' upperName ',' upperName ',' integer '>' { ($2, $4, $6) } + pType :: { Ty } pType : paT '->' pType { TyF $1 $3 } | paT '=>' pType { TyC $1 $3 } @@ -175,9 +195,12 @@ ppT :: { Ty } ppT : lowerName { TyVar $1 } | pTycon { TyApp $1 [] } -pTycon :: { String } -pTycon : upperName { $1 } - | '(' ')' { "()" } +pTycon :: { TyCon } +pTycon : upperName { TyCon $1 } + | '(' ')' { TyCon "()" } + | SCALAR { SCALAR } + | VECTOR { VECTOR } + | VECTUPLE { VECTUPLE } { parse :: String -> Either String Info diff --git a/utils/genprimopcode/ParserM.hs b/utils/genprimopcode/ParserM.hs index 8093675651..aaaf6ac66f 100644 --- a/utils/genprimopcode/ParserM.hs +++ b/utils/genprimopcode/ParserM.hs @@ -67,6 +67,10 @@ data Token = TEOF | THashCloseParen | TOpenBrace | TCloseBrace + | TOpenBracket + | TCloseBracket + | TOpenAngle + | TCloseAngle | TSection | TPrimop | TPseudoop @@ -91,6 +95,10 @@ data Token = TEOF | TInfixL | TInfixR | TNothing + | TVector + | TSCALAR + | TVECTOR + | TVECTUPLE deriving Show -- Actions diff --git a/utils/genprimopcode/Syntax.hs b/utils/genprimopcode/Syntax.hs index 333ea2c4c7..d0c380cf59 100644 --- a/utils/genprimopcode/Syntax.hs +++ b/utils/genprimopcode/Syntax.hs @@ -19,6 +19,15 @@ data Entry cat :: Category, -- category desc :: String, -- description opts :: [Option] } -- default overrides + | PrimVecOpSpec { cons :: String, -- PrimOp name + name :: String, -- name in prog text + prefix :: String, -- prefix for generated names + veclen :: Int, -- vector length + elemrep :: String, -- vector ElemRep + ty :: Ty, -- type + cat :: Category, -- category + desc :: String, -- description + opts :: [Option] } -- default overrides | PseudoOpSpec { name :: String, -- name in prog text ty :: Ty, -- type desc :: String, -- description @@ -29,6 +38,12 @@ data Entry | PrimClassSpec { cls :: Ty, -- name in prog text desc :: String, -- description opts :: [Option] } -- default overrides + | PrimVecTypeSpec { ty :: Ty, -- name in prog text + prefix :: String, -- prefix for generated names + veclen :: Int, -- vector length + elemrep :: String, -- vector ElemRep + desc :: String, -- description + opts :: [Option] } -- default overrides | Section { title :: String, -- section title desc :: String } -- description deriving Show @@ -37,12 +52,17 @@ is_primop :: Entry -> Bool is_primop (PrimOpSpec _ _ _ _ _ _) = True is_primop _ = False +is_primtype :: Entry -> Bool +is_primtype (PrimTypeSpec {}) = True +is_primtype _ = False + -- a binding of property to value data Option = OptionFalse String -- name = False | OptionTrue String -- name = True | OptionString String String -- name = { ... unparsed stuff ... } | OptionInteger String Int -- name = <int> + | OptionVector [(String,String,Int)] -- name = [(,...),...] | OptionFixity (Maybe Fixity) -- fixity = infix{,l,r} <int> | Nothing deriving Show @@ -62,7 +82,20 @@ data Ty deriving (Eq,Show) type TyVar = String -type TyCon = String + +data TyCon = TyCon String + | SCALAR + | VECTOR + | VECTUPLE + | VecTyCon String String + deriving (Eq, Ord) + +instance Show TyCon where + show (TyCon tc) = tc + show SCALAR = "SCALAR" + show VECTOR = "VECTOR" + show VECTUPLE = "VECTUPLE" + show (VecTyCon tc _) = tc -- Follow definitions of Fixity and FixityDirection in GHC @@ -118,7 +151,7 @@ sanityPrimOp def_names p sane_ty :: Category -> Ty -> Bool sane_ty Compare (TyF t1 (TyF t2 td)) - | t1 == t2 && td == TyApp "Int#" [] = True + | t1 == t2 && td == TyApp (TyCon "Int#") [] = True sane_ty Monadic (TyF t1 td) | t1 == td = True sane_ty Dyadic (TyF t1 (TyF t2 td)) @@ -133,6 +166,7 @@ get_attrib_name (OptionFalse nm) = nm get_attrib_name (OptionTrue nm) = nm get_attrib_name (OptionString nm _) = nm get_attrib_name (OptionInteger nm _) = nm +get_attrib_name (OptionVector _) = "vector" get_attrib_name (OptionFixity _) = "fixity" lookup_attrib :: String -> [Option] -> Maybe Option @@ -140,3 +174,7 @@ lookup_attrib _ [] = Nothing lookup_attrib nm (a:as) = if get_attrib_name a == nm then Just a else lookup_attrib nm as +is_vector :: Entry -> Bool +is_vector i = case lookup_attrib "vector" (opts i) of + Nothing -> False + _ -> True |