diff options
| author | Geoffrey Mainland <gmainlan@microsoft.com> | 2013-08-21 16:18:24 +0100 |
|---|---|---|
| committer | Geoffrey Mainland <gmainlan@microsoft.com> | 2013-09-22 22:33:59 -0400 |
| commit | 16b350a4227c96e09533c6f165895f50003d3801 (patch) | |
| tree | f2fbf6f0f4b5ea2a406cd6a078fc1cb7cce31ad5 | |
| parent | da5a647c0c49fee7531ef4c076b1c9e6a9d0fe6d (diff) | |
| download | haskell-16b350a4227c96e09533c6f165895f50003d3801.tar.gz | |
SIMD primops are now generated using schemas that are polymorphic in
width and element type.
SIMD primops are now polymorphic in vector size and element type, but
only internally to the compiler. More specifically, utils/genprimopcode
has been extended so that it "knows" about SIMD vectors. This allows us
to, for example, write a single definition for the "add two vectors"
primop in primops.txt.pp and have it instantiated at many vector types.
This generates a primop in GHC.Prim for each vector type at which "add
two vectors" is instantiated, but only one data constructor for the
PrimOp data type, so the code generator is much, much simpler.
| -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 |