diff --git a/compiler/GHC/Builtin/PrimOps/Casts.hs b/compiler/GHC/Builtin/PrimOps/Casts.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Builtin/PrimOps/Casts.hs @@ -0,0 +1,212 @@ +{- +This module contains helpers to cast variables +between different Int/WordReps in StgLand. + +-} + +module GHC.Builtin.PrimOps.Casts + ( getCasts ) +where + +import GHC.Prelude + +import GHC.Core.TyCon +import GHC.Utils.Outputable +import GHC.Utils.Panic +import GHC.Utils.Panic.Plain +import GHC.Types.RepType +import GHC.Core.Type +import GHC.Builtin.Types.Prim + +import GHC.Builtin.PrimOps +import GHC.Plugins (HasDebugCallStack) + +{- Note [PrimRep based casting] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module contains a number of utility functions useful when +converting between variables of differing PrimReps. + +The general pattern is: +* We have two primReps `from_rep` and `to_rep`. +* We want a list of PrimOps we can apply to a variable of rep `from_rep`. +Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving +us a variable of the returned type at each step. + +E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)]. +We can use this result to construct a function of type +`StgExpr -> StgExpr` by construction an expression + + case op1# of (x' :: ty1) -> case op2# x' of x' -> + +Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing +the same register but just relabeling it as another width. +However this is might not always be possible or the required optimizations +simply not implemented in the backend. This means currently many of these casts +will be cheap but not all of them will be completely zero-cost. + +-} + +-- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep. +-- See Note [PrimRep based casting] +getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)] +getCasts from_rep to_rep + -- No-op + | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $ + to_rep == from_rep + = [] + + -- Float <-> Double + | to_rep == FloatRep = + assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $ + [(DoubleToFloatOp,floatPrimTy)] + | to_rep == DoubleRep = + assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $ + [(FloatToDoubleOp,doublePrimTy)] + + -- Addr <-> Word/Int + | to_rep == AddrRep = wordOrIntToAddrRep from_rep + | from_rep == AddrRep = addrToWordOrIntRep to_rep + + -- Int* -> Int* + | primRepIsInt from_rep + , primRepIsInt to_rep + = sizedIntToSizedInt from_rep to_rep + + -- Word* -> Word* + | primRepIsWord from_rep + , primRepIsWord to_rep + = sizedWordToSizedWord from_rep to_rep + + -- Word* -> Int* + | primRepIsWord from_rep + , primRepIsInt to_rep + = let (op1,r1) = wordToIntRep from_rep + in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep + + -- Int* -> Word* + | primRepIsInt from_rep + , primRepIsWord to_rep + = let (op1,r1) = intToWordRep from_rep + in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep + + | otherwise = pprPanic "getCasts:Unexpect rep combination" + (ppr (from_rep,to_rep)) + +wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep +wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)] +wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)] +wordOrIntToAddrRep r + | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)] + | primRepIsWord r = + let (op1,r1) = wordToIntRep r + in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)] + | otherwise = pprPanic "Rep not word or int rep" (ppr r) + +addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)] +-- Machine sizes +addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)] +addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)] +-- Explicitly sized reps +addrToWordOrIntRep r + | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r + | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r + | otherwise = pprPanic "Target rep not word or int rep" (ppr r) + + +-- WordX# -> IntX# (same size), argument is source rep +wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +wordToIntRep rep + = case rep of + (WordRep) -> (WordToIntOp, IntRep) + (Word8Rep) -> (Word8ToInt8Op, Int8Rep) + (Word16Rep) -> (Word16ToInt16Op, Int16Rep) + (Word32Rep) -> (Word32ToInt32Op, Int32Rep) + (Word64Rep) -> (Word64ToInt64Op, Int64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- IntX# -> WordX#, argument is source rep +intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep) +intToWordRep rep + = case rep of + (IntRep) -> (IntToWordOp, WordRep) + (Int8Rep) -> (Int8ToWord8Op, Word8Rep) + (Int16Rep) -> (Int16ToWord16Op, Word16Rep) + (Int32Rep) -> (Int32ToWord32Op, Word32Rep) + (Int64Rep) -> (Int64ToWord64Op, Word64Rep) + _ -> pprPanic "Rep not a wordRep" (ppr rep) + +-- Casts between any size int to any other size of int +sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedIntToSizedInt r1 r2 + | r1 == r2 = [] +-- Cast to Int# +sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)] +-- Cast from Int# +sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)] +-- Sized to differently sized must go over machine word. +sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)] + +-- Casts between any size Word to any other size of Word +sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)] +sizedWordToSizedWord r1 r2 + | r1 == r2 = [] +-- Cast to Word# +sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)] +-- Cast from Word# +sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)] +-- Conversion between different non-machine sizes must go via machine word. +sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)] + + +-- Prefer the definitions above this line if possible +---------------------- + + +-- Int*# to Int# +{-# INLINE intToMachineInt #-} +intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intToMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + (Int8Rep) -> Int8ToIntOp + (Int16Rep) -> Int16ToIntOp + (Int32Rep) -> Int32ToIntOp + (Int64Rep) -> Int64ToIntOp + _ -> pprPanic "Source rep not int" $ ppr r + +-- Int# to Int*# +{-# INLINE intFromMachineInt #-} +intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp +intFromMachineInt r = + assertPpr (primRepIsInt r) (ppr r) $ + case r of + Int8Rep -> IntToInt8Op + Int16Rep -> IntToInt16Op + Int32Rep -> IntToInt32Op + Int64Rep -> IntToInt64Op + _ -> pprPanic "Dest rep not sized int" $ ppr r + +-- Word# to Word*# +{-# INLINE wordFromMachineWord #-} +wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordFromMachineWord r = + assert (primRepIsWord r) $ + case r of + Word8Rep -> WordToWord8Op + Word16Rep -> WordToWord16Op + Word32Rep -> WordToWord32Op + Word64Rep -> WordToWord64Op + _ -> pprPanic "Dest rep not sized word" $ ppr r + +-- Word*# to Word# +{-# INLINE wordToMachineWord #-} +wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp +wordToMachineWord r = + assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $ + case r of + Word8Rep -> Word8ToWordOp + Word16Rep -> Word16ToWordOp + Word32Rep -> Word32ToWordOp + Word64Rep -> Word64ToWordOp + _ -> pprPanic "Dest rep not sized word" $ ppr r diff --git a/compiler/GHC/Cmm/ContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs --- a/compiler/GHC/Cmm/ContFlowOpt.hs +++ b/compiler/GHC/Cmm/ContFlowOpt.hs @@ -12,7 +12,7 @@ import GHC.Prelude hiding (succ, unzip, zip) -import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Block hiding (blockConcat) import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -94,6 +94,10 @@ "!=" { kw CmmT_Ne } "&&" { kw CmmT_BoolAnd } "||" { kw CmmT_BoolOr } + "%relaxed" { kw CmmT_Relaxed } + "%acquire" { kw CmmT_Acquire } + "%release" { kw CmmT_Release } + "%seq_cst" { kw CmmT_SeqCst } "True" { kw CmmT_True } "False" { kw CmmT_False } @@ -183,6 +187,10 @@ | CmmT_False | CmmT_True | CmmT_likely + | CmmT_Relaxed + | CmmT_Acquire + | CmmT_Release + | CmmT_SeqCst deriving (Show) -- ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -170,9 +170,21 @@ platform <- getPlatform erep <- lintCmmExpr expr let reg_ty = cmmRegType platform reg - if (erep `cmmEqType_ignoring_ptrhood` reg_ty) - then return () - else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + unless (compat_regs erep reg_ty) $ + cmmLintAssignErr (CmmAssign reg expr) erep reg_ty + where + compat_regs :: CmmType -> CmmType -> Bool + compat_regs ty1 ty2 + -- As noted in #22297, SIMD vector registers can be used for + -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats, + -- or 4 Int32s, or 2 Word64s, ... + -- To allow this, we relax the check: we only ensure that the widths + -- match, until we can find a more robust solution. + | isVecType ty1 + , isVecType ty2 + = typeWidth ty1 == typeWidth ty2 + | otherwise + = cmmEqType_ignoring_ptrhood ty1 ty2 CmmStore l r _alignment -> do _ <- lintCmmExpr l diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -194,7 +194,28 @@ a 32-bit machine) then the call will push as many words as necessary to the stack to accommodate it (e.g. 2). +Memory ordering +--------------- +Cmm respects the C11 memory model and distinguishes between non-atomic and +atomic memory accesses. In C11 fashion, atomic accesses can provide a number of +memory ordering guarantees. These are supported in Cmm syntax as follows: + + W_[ptr] = ...; // a non-atomic store + %relaxed W_[ptr] = ...; // an atomic store with relaxed ordering semantics + %release W_[ptr] = ...; // an atomic store with release ordering semantics + + x = W_(ptr); // a non-atomic load + x = %relaxed W_[ptr]; // an atomic load with relaxed ordering + x = %acquire W_[ptr]; // an atomic load with acquire ordering + // or equivalently... + x = prim %load_acquire64(ptr); + +Here we used W_ as an example but these operations can be used on all Cmm +types. + +See Note [Heap memory barriers] in SMP.h for details. + ----------------------------------------------------------------------------- -} { @@ -317,6 +338,10 @@ 'True' { L _ (CmmT_True ) } 'False' { L _ (CmmT_False) } 'likely'{ L _ (CmmT_likely)} + 'relaxed'{ L _ (CmmT_Relaxed)} + 'acquire'{ L _ (CmmT_Acquire)} + 'release'{ L _ (CmmT_Release)} + 'seq_cst'{ L _ (CmmT_SeqCst)} 'CLOSURE' { L _ (CmmT_CLOSURE) } 'INFO_TABLE' { L _ (CmmT_INFO_TABLE) } @@ -632,8 +657,23 @@ | lreg '=' expr ';' { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) } + + -- Use lreg instead of local_reg to avoid ambiguity + | lreg '=' mem_ordering type '[' expr ']' ';' + { do reg <- $1; + let lreg = case reg of + { CmmLocal r -> r + ; other -> pprPanic "CmmParse:" (ppr reg <> text "not a local register") + } ; + mord <- $3; + let { ty = $4; w = typeWidth ty }; + e <- $6; + let op = MO_AtomicRead w mord; + withSourceNote $2 $7 $ code (emitPrimCall [lreg] op [e]) } + | mem_ordering type '[' expr ']' '=' expr ';' + { do mord <- $1; withSourceNote $3 $8 (doStore (Just mord) $2 $4 $7) } | type '[' expr ']' '=' expr ';' - { withSourceNote $2 $7 (doStore $1 $3 $6) } + { withSourceNote $2 $7 (doStore Nothing $1 $3 $6) } -- Gah! We really want to say "foreign_results" but that causes -- a shift/reduce conflict with assignment. We either @@ -683,6 +723,14 @@ | GLOBALREG '=' expr_or_unknown { do e <- $3; return [($1, e)] } +-- | A memory ordering +mem_ordering :: { CmmParse MemoryOrdering } +mem_ordering + : 'relaxed' { do return MemOrderRelaxed } + | 'release' { do return MemOrderRelease } + | 'acquire' { do return MemOrderAcquire } + | 'seq_cst' { do return MemOrderSeqCst } + -- | Used by unwind to indicate unknown unwinding values. expr_or_unknown :: { CmmParse (Maybe CmmExpr) } @@ -957,6 +1005,7 @@ platform = profilePlatform profile -- we understand a subset of C-- primitives: +machOps :: UniqFM FastString (Width -> MachOp) machOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ ( "add", MO_Add ), @@ -1078,37 +1127,32 @@ ( "suspendThread", (MO_SuspendThread,) ), ( "resumeThread", (MO_ResumeThread,) ), - ("prefetch0", (MO_Prefetch_Data 0,)), - ("prefetch1", (MO_Prefetch_Data 1,)), - ("prefetch2", (MO_Prefetch_Data 2,)), - ("prefetch3", (MO_Prefetch_Data 3,)), - - ( "popcnt8", (MO_PopCnt W8,)), - ( "popcnt16", (MO_PopCnt W16,)), - ( "popcnt32", (MO_PopCnt W32,)), - ( "popcnt64", (MO_PopCnt W64,)), - - ( "pdep8", (MO_Pdep W8,)), - ( "pdep16", (MO_Pdep W16,)), - ( "pdep32", (MO_Pdep W32,)), - ( "pdep64", (MO_Pdep W64,)), - - ( "pext8", (MO_Pext W8,)), - ( "pext16", (MO_Pext W16,)), - ( "pext32", (MO_Pext W32,)), - ( "pext64", (MO_Pext W64,)), - - ( "cmpxchg8", (MO_Cmpxchg W8,)), - ( "cmpxchg16", (MO_Cmpxchg W16,)), - ( "cmpxchg32", (MO_Cmpxchg W32,)), - ( "cmpxchg64", (MO_Cmpxchg W64,)), - - ( "xchg8", (MO_Xchg W8,)), - ( "xchg16", (MO_Xchg W16,)), - ( "xchg32", (MO_Xchg W32,)), - ( "xchg64", (MO_Xchg W64,)) + ( "prefetch0", (MO_Prefetch_Data 0,)), + ( "prefetch1", (MO_Prefetch_Data 1,)), + ( "prefetch2", (MO_Prefetch_Data 2,)), + ( "prefetch3", (MO_Prefetch_Data 3,)) + ] ++ concat + [ allWidths "popcnt" MO_PopCnt + , allWidths "pdep" MO_Pdep + , allWidths "pext" MO_Pext + , allWidths "cmpxchg" MO_Cmpxchg + , allWidths "xchg" MO_Xchg + , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire) + , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst) + , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease) + , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst) ] where + allWidths + :: String + -> (Width -> CallishMachOp) + -> [(FastString, a -> (CallishMachOp, a))] + allWidths name f = + [ (mkFastString $ name ++ show (widthInBits w), (f w,)) + | w <- [W8, W16, W32, W64] + ] + memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr]) memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument" memcpyLikeTweakArgs op args@(_:_) = @@ -1352,8 +1396,12 @@ let (p, args') = f args code (emitPrimCall (map fst results) p args') -doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse () -doStore rep addr_code val_code +doStore :: Maybe MemoryOrdering + -> CmmType + -> CmmParse CmmExpr -- ^ address + -> CmmParse CmmExpr -- ^ value + -> CmmParse () +doStore mem_ord rep addr_code val_code = do platform <- getPlatform addr <- addr_code val <- val_code @@ -1367,7 +1415,7 @@ let coerce_val | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val] | otherwise = val - emitStore addr coerce_val + emitStore mem_ord addr coerce_val -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -115,7 +115,7 @@ AddrRep -> bWord platform FloatRep -> f32 DoubleRep -> f64 - (VecRep len rep) -> vec len (primElemRepCmmType rep) + VecRep len rep -> vec len (primElemRepCmmType rep) slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case @@ -125,6 +125,7 @@ Word64Slot -> b64 FloatSlot -> f32 DoubleSlot -> f64 + VecSlot l e -> vec l (primElemRepCmmType e) primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep = b8 diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1535,8 +1535,8 @@ -- -- Atomic read-modify-write. MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop) - MO_AtomicRead w -> mkCCall (atomicReadLabel w) - MO_AtomicWrite w -> mkCCall (atomicWriteLabel w) + MO_AtomicRead w _ -> mkCCall (atomicReadLabel w) + MO_AtomicWrite w _ -> mkCCall (atomicWriteLabel w) MO_Cmpxchg w -> mkCCall (cmpxchgLabel w) -- -- Should be an AtomicRMW variant eventually. -- -- Sequential consistent. diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -1174,7 +1174,7 @@ (n_reg, n_code) <- getSomeReg n return (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr] +genCCall (PrimTarget (MO_AtomicRead width _)) [dst] [addr] = do let fmt = intFormat width reg_dst = getLocalRegReg dst form = if widthInBits width == 64 then DS else D @@ -1201,7 +1201,7 @@ -- This is also what gcc does. -genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do +genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do code <- assignMem_IntCode (intFormat width) addr val return $ unitOL HWSYNC `appOL` code @@ -2068,8 +2068,8 @@ MO_AtomicRMW {} -> unsupported MO_Cmpxchg w -> (cmpxchgLabel w, False) MO_Xchg w -> (xchgLabel w, False) - MO_AtomicRead _ -> unsupported - MO_AtomicWrite _ -> unsupported + MO_AtomicRead _ _ -> unsupported + MO_AtomicWrite _ _ -> unsupported MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -2167,8 +2167,8 @@ genSimplePrim bid (MO_Pext width) [dst] [src,mask] = genPext bid width dst src mask genSimplePrim bid (MO_Clz width) [dst] [src] = genClz bid width dst src genSimplePrim bid (MO_UF_Conv width) [dst] [src] = genWordToFloat bid width dst src -genSimplePrim _ (MO_AtomicRead w) [dst] [addr] = genAtomicRead w dst addr -genSimplePrim _ (MO_AtomicWrite w) [] [addr,val] = genAtomicWrite w addr val +genSimplePrim _ (MO_AtomicRead w mo) [dst] [addr] = genAtomicRead w mo dst addr +genSimplePrim _ (MO_AtomicWrite w mo) [] [addr,val] = genAtomicWrite w mo addr val genSimplePrim bid (MO_Cmpxchg width) [dst] [addr,old,new] = genCmpXchg bid width dst addr old new genSimplePrim _ (MO_Xchg width) [dst] [addr, value] = genXchg width dst addr value genSimplePrim _ (MO_AddWordC w) [r,c] [x,y] = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y @@ -3941,15 +3941,20 @@ -- TODO: generate assembly instead genPrimCCall bid (word2FloatLabel width) [dst] [src] -genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock -genAtomicRead width dst addr = do +genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock +genAtomicRead width _mord dst addr = do load_code <- intLoadCode (MOV (intFormat width)) addr return (load_code (getLocalRegReg dst)) -genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock -genAtomicWrite width addr val = do +genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock +genAtomicWrite width mord addr val = do code <- assignMem_IntCode (intFormat width) addr val - return $ code `snocOL` MFENCE + let needs_fence = case mord of + MemOrderSeqCst -> True + MemOrderRelease -> True + MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty + MemOrderRelaxed -> False + return $ if needs_fence then code `snocOL` MFENCE else code genCmpXchg :: BlockId diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -949,8 +949,9 @@ MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop) MO_Cmpxchg w -> ftext (cmpxchgLabel w) MO_Xchg w -> ftext (xchgLabel w) - MO_AtomicRead w -> ftext (atomicReadLabel w) - MO_AtomicWrite w -> ftext (atomicWriteLabel w) + -- TODO: handle orderings + MO_AtomicRead w _ -> ftext (atomicReadLabel w) + MO_AtomicWrite w _ -> ftext (atomicWriteLabel w) MO_UF_Conv w -> ftext (word2FloatLabel w) MO_S_Mul2 {} -> unsupported diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -46,7 +46,7 @@ import Data.List ( nub ) import Data.Maybe ( catMaybes ) -type Atomic = Bool +type Atomic = Maybe MemoryOrdering type LlvmStatements = OrdList LlvmStatement data Signage = Signed | Unsigned deriving (Eq, Show) @@ -266,9 +266,9 @@ retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst statement $ Store retVar dstVar Nothing -genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do +genCall (PrimTarget (MO_AtomicRead _ mem_ord)) [dst] [addr] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) - v1 <- genLoadW True addr (localRegType dst) NaturallyAligned + v1 <- genLoadW (Just mem_ord) addr (localRegType dst) NaturallyAligned statement $ Store v1 dstV Nothing genCall (PrimTarget (MO_Cmpxchg _width)) @@ -295,13 +295,14 @@ resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst) statement $ Store resVar dstV Nothing -genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do +genCall (PrimTarget (MO_AtomicWrite _width mem_ord)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr valVar <- exprToVarW val let ptrTy = pLift $ getVarType valVar ptrExpr = Cast LM_Inttoptr addrVar ptrTy ptrVar <- doExprW ptrTy ptrExpr - statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst + let ordering = convertMemoryOrdering mem_ord + statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar ordering -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. @@ -1013,11 +1014,11 @@ MO_Touch -> unsupported MO_UF_Conv _ -> unsupported - MO_AtomicRead _ -> unsupported - MO_AtomicRMW _ _ -> unsupported - MO_AtomicWrite _ -> unsupported - MO_Cmpxchg _ -> unsupported - MO_Xchg _ -> unsupported + MO_AtomicRead _ _ -> unsupported + MO_AtomicRMW _ _ -> unsupported + MO_AtomicWrite _ _ -> unsupported + MO_Cmpxchg _ -> unsupported + MO_Xchg _ -> unsupported MO_I64_ToI -> dontReach64 MO_I64_FromI -> dontReach64 @@ -1369,7 +1370,7 @@ -> genLit opt lit CmmLoad e' ty align - -> genLoad False e' ty align + -> genLoad Nothing e' ty align -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. @@ -1901,7 +1902,8 @@ mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression mkLoad atomic vptr alignment - | atomic = ALoad SyncSeqCst False vptr + | Just mem_ord <- atomic + = ALoad (convertMemoryOrdering mem_ord) False vptr | otherwise = Load vptr align where ty = pLower (getVarType vptr) @@ -2037,6 +2039,12 @@ -- ----------------------------------------------------------------------------- -- * Misc -- + +convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering +convertMemoryOrdering MemOrderRelaxed = SyncMonotonic +convertMemoryOrdering MemOrderAcquire = SyncAcquire +convertMemoryOrdering MemOrderRelease = SyncRelease +convertMemoryOrdering MemOrderSeqCst = SyncSeqCst -- | Find CmmRegs that get assigned and allocate them on the stack -- diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -248,8 +248,10 @@ dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id - -> dmdAnalBindLetUp top_lvl env id rhs anal_body - _ -> dmdAnalBindLetDown top_lvl env dmd bind anal_body + -> dmdAnalBindLetUp top_lvl env_rhs id rhs anal_body + _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind anal_body + where + env_rhs = enterDFun bind env -- | Annotates uninteresting top level functions ('isInterestingTopLevelFn') -- with 'topDmd', the rest with the given demand. @@ -448,8 +450,9 @@ !(!bndrs', !scrut_sd) | DataAlt _ <- alt -- See Note [Demand on the scrutinee of a product case] + , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds -- See Note [Demand on case-alternative binders] - , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds + , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds) , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' = (bndrs', scrut_sd) | otherwise @@ -559,7 +562,7 @@ | otherwise = False -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) +dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType CoreAlt dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs @@ -567,27 +570,29 @@ -- See Note [Demand on case-alternative binders] -- we can't use the scrut_sd, because it says 'Prod' and we'll use -- topSubDmd anyway for scrutinees of sum types. - (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds + scrut_sd = scrutSubDmd case_bndr_sd dmds + dmds' = fieldBndrDmds scrut_sd (length dmds) -- Do not put a thunk into the Alt !new_ids = setBndrsDemandInfo bndrs dmds' = WithDmdType alt_ty (Alt con new_ids rhs') --- Precondition: The SubDemand is not a Call -- See Note [Demand on the scrutinee of a product case] --- and Note [Demand on case-alternative binders] -addCaseBndrDmd :: SubDemand -- On the case binder - -> [Demand] -- On the fields of the constructor - -> (SubDemand, [Demand]) - -- SubDemand on the case binder incl. field demands - -- and final demands for the components of the constructor -addCaseBndrDmd case_sd fld_dmds - | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd - = (scrut_sd, ds) - | otherwise - = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition - where - scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds +scrutSubDmd :: SubDemand -> [Demand] -> SubDemand +scrutSubDmd case_sd fld_dmds = + -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $ + case_sd `plusSubDmd` mkProd Unboxed fld_dmds +-- See Note [Demand on case-alternative binders] +fieldBndrDmds :: SubDemand -- on the scrutinee + -> Arity + -> [Demand] -- Final demands for the components of the DataCon +fieldBndrDmds scrut_sd n_flds = + case viewProd n_flds scrut_sd of + Just (_, ds) -> ds + Nothing -> replicate n_flds topDmd + -- Either an arity mismatch or scrut_sd was a call demand. + -- See Note [Untyped demand on case-alternative binders] + {- Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -769,6 +774,44 @@ This is needed even for non-product types, in case the case-binder is used but the components of the case alternative are not. +Note [Untyped demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder +may be a call demand or have a different number of fields than the constructor +of the case alternative it is used in. From T22039: + + blarg :: (Int, Int) -> Int + blarg (x,y) = x+y + -- blarg :: <1!P(1L,1L)> + + f :: Either Int Int -> Int + f Left{} = 0 + f e = blarg (unsafeCoerce e) + ==> { desugars to } + f = \ (ds_d1nV :: Either Int Int) -> + case ds_d1nV of wild_X1 { + Left ds_d1oV -> lvl_s1Q6; + Right ipv_s1Pl -> + blarg + (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of + { UnsafeRefl co_a1oT -> + wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int)) + }) + } + +The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call +to `blarg`, but `Right` only has one field. Although the code will crash when +executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively +approximate with Top instead of panicking because of the mismatch. +In #22039, this kind of code was guarded behind a safe `cast` and thus dead +code, but nevertheless led to a panic of the compiler. + +You might wonder why the same problem doesn't come up when scrutinising a +product type instead of a sum type. It appears that for products, `wild_X1` +will be inlined before DmdAnal. + +See also Note [mkWWstr and unsafeCoerce] for a related issue. + Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates @@ -829,8 +872,9 @@ -- See Note [What are demand signatures?] in "GHC.Types.Demand" dmdTransform env var sd -- Data constructors - | isDataConWorkId var - = dmdTransformDataConSig (idArity var) sd + | Just con <- isDataConWorkId_maybe var + = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $ + dmdTransformDataConSig (dataConRepStrictness con) sd -- Dictionary component selectors -- Used to be controlled by a flag. -- See #18429 for some perf measurements. @@ -1492,13 +1536,18 @@ Historical note: #14955 describes how I got this fix wrong the first time. -Note that the simplicity of this fix implies that INLINE functions (such as -wrapper functions after the WW run) will never say that they unbox class -dictionaries. That's not ideal, but not worth losing sleep over, as INLINE -functions will have been inlined by the time we run demand analysis so we'll -see the unboxing around the worker in client modules. I got aware of the issue -in T5075 by the change in boxity of loop between demand analysis runs. +2. -fspecialise-aggressively. As #21286 shows, the same phenomenon can occur + occur without INLINABLE, when we use -fexpose-all-unfoldings and + -fspecialise-aggressively to do vigorous cross-module specialisation. +3. #18421 found that unboxing a dictionary can also make the worker less likely + to inline; the inlining heuristics seem to prefer to inline a function + applied to a dictionary over a function applied to a bunch of functions. + +TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing +a raft of higher-order functions isn't a huge win anyway -- you really want to +specialise the function. + Note [Worker argument budget] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'finaliseArgBoxities' we don't want to generate workers with zillions of @@ -1842,14 +1891,6 @@ -- L demand doesn't get both'd with the Bot coming up from the inner -- call to f. So we just get an L demand for x for g. -{- -Note [Do not strictify the argument dictionaries of a dfun] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The typechecker can tie recursive knots involving dfuns, so we do the -conservative thing and refrain from strictifying a dfun's argument -dictionaries. --} - setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds | isTyVar b = b : setBndrsDemandInfo bs ds @@ -1988,6 +2029,16 @@ , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs 3) } +-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun +-- binding. Part of the mechanism that detects +-- Note [Do not strictify a DFun's parameter dictionaries]. +enterDFun :: CoreBind -> AnalEnv -> AnalEnv +enterDFun bind env + | any isDFunId (bindersOf bind) + = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } } + | otherwise + = env + emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv @@ -2039,58 +2090,74 @@ id_ty = idType id strictify dmd - -- See Note [Making dictionaries strict] + -- See Note [Making dictionary parameters strict] + -- and Note [Do not strictify a DFun's parameter dictionaries] | dmd_strict_dicts (ae_opts env) - -- We never want to strictify a recursive let. At the moment - -- findBndrDmd is never called for recursive lets; if that - -- changes, we need a RecFlag parameter and another guard here. = strictifyDictDmd id_ty dmd | otherwise = dmd fam_envs = ae_fam_envs env -{- Note [Making dictionaries strict] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Making dictionary parameters strict] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries. Why? * Generally CBV is more efficient. -* Dictionaries are always non-bottom; and never take much work to - compute. E.g. a dfun from an instance decl always returns a dicionary +* A datatype dictionary is always non-bottom and never takes much work to + compute. E.g. a DFun from an instance decl always returns a dictionary record immediately. See DFunUnfolding in CoreSyn. See also Note [Recursive superclasses] in TcInstDcls. -* The strictness analyser will then unbox dictionaries and pass the - methods individually, rather than in a bundle. If there are a lot of - methods that might be bad; but worker/wrapper already does throttling. +See #17758 for more background and perf numbers. +Wrinkles: + * A newtype dictionary is *not* always non-bottom. E.g. class C a where op :: a -> a instance C Int where op = error "urk" Now a value of type (C Int) is just a newtype wrapper (a cast) around the error thunk. Don't strictify these! -See #17758 for more background and perf numbers. +* Strictifying DFuns risks destroying the invariant that DFuns never take much + work to compute, so we don't do it. + See Note [Do not strictify a DFun's parameter dictionaries] for details. +* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do + so; see Note [Do not unbox class dictionaries]. + The implementation is extremly simple: just make the strictness analyser strictify the demand on a dictionary binder in -'findBndrDmd'. +'findBndrDmd' if the binder does not belong to a DFun. -However there is one case where this can make performance worse. -For the principle consider some function at the core level: - myEq :: Eq a => a -> a -> Bool - myEq eqDict x y = ((==) eqDict) x y -If we make the dictionary strict then WW can fire turning this into: - $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool - $wmyEq eq x y = eq x y -Which *usually* performs better. However if the dictionary is known we -are far more likely to inline a function applied to the dictionary than -to inline one applied to a function. Sometimes this makes just enough -of a difference to stop a function from inlining. This is documented in #18421. +Note [Do not strictify a DFun's parameter dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker can tie recursive knots involving (non-recursive) DFuns, so +we must not strictify a DFun's parameter dictionaries (#22549). +T22549 has an example involving undecidable instances that <>s when we +strictify the DFun of, e.g., `$fEqSeqT`: -It's somewhat similar to Note [Do not unbox class dictionaries] although -here our problem is with the inliner, not the specializer. + Main.$fEqSeqT + = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) -> + GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad) + ($c/= @m @a $dEq $dMonad) + + Rec { + $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity + $dEq_b = ... $dEq_a ... + } + +If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a +giant, <>ing thunk. + +To prevent that, we never strictify dictionary params when inside a DFun. +That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun. + +See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather +similar example in #20836. We may never speculate *arguments* of (recursive) +DFun calls, likewise we should not mark *formal parameters* of recursive DFuns +as strict. Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -1733,6 +1733,10 @@ The problem is very similar to Note [Eta reduction in recursive RHSs]. Here as well as there it is *unsound* to change the termination properties of the very function whose termination properties we are exploiting. + +It is also similar to Note [Do not strictify a DFun's parameter dictionaries], +where marking recursive DFuns (of undecidable *instances*) strict in dictionary +*parameters* leads to quite the same change in termination as above. -} data FloatingBind diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -727,8 +727,8 @@ Just n -> return n setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env - hsc_env <- getSession - (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ + (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do + hsc_env <- getSession liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan setSession hsc_env1 case upsweep_ok of diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -945,7 +945,8 @@ ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) ; let match_args (pat, fail_op) (vs,body) - = do { var <- selectSimpleMatchVarL Many pat + = putSrcSpanDs (getLocA pat) $ + do { var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -50,10 +50,8 @@ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags) writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n" -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. runWindres logger dflags $ map GHC.SysTools.Option $ ["--input="++rc_filename, diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -79,11 +79,11 @@ myExtraGccViaCFlags <- getSetting "GCC extra via C opts" cc_prog <- getToolSetting "C compiler command" cxx_prog <- getToolSetting "C++ compiler command" - cc_args_str <- getSetting "C compiler flags" - cxx_args_str <- getSetting "C++ compiler flags" + cc_args_str <- getToolSetting "C compiler flags" + cxx_args_str <- getToolSetting "C++ compiler flags" gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie" cpp_prog <- getToolSetting "Haskell CPP command" - cpp_args_str <- getSetting "Haskell CPP flags" + cpp_args_str <- getToolSetting "Haskell CPP flags" platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings @@ -125,13 +125,13 @@ -- Other things being equal, as and ld are simply gcc - cc_link_args_str <- getSetting "C compiler link flags" + cc_link_args_str <- getToolSetting "C compiler link flags" let as_prog = cc_prog as_args = map Option cc_args ld_prog = cc_prog ld_args = map Option (cc_args ++ words cc_link_args_str) ld_r_prog <- getToolSetting "Merge objects command" - ld_r_args <- getSetting "Merge objects flags" + ld_r_args <- getToolSetting "Merge objects flags" let ld_r | null ld_r_prog = Nothing | otherwise = Just (ld_r_prog, map Option $ words ld_r_args) diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -326,7 +326,7 @@ rhsCard :: Id -> Card rhsCard bndr | is_thunk = oneifyCard n - | otherwise = peelManyCalls (idArity bndr) cd + | otherwise = fst (peelManyCalls (idArity bndr) cd) where is_thunk = idArity bndr == 0 -- Let's pray idDemandInfo is still OK after unarise... diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -46,10 +46,19 @@ t_1 :: TYPE r_1, ..., t_n :: TYPE r_n s_1 :: TYPE p_1, ..., a_n :: TYPE p_n -Then we must check that each r_i is compatible with s_i. Compatibility -is weaker than on-the-nose equality: for example, IntRep and WordRep are -compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint. +Before unarisation, we must check that each r_i is compatible with s_i. +Compatibility is weaker than on-the-nose equality: for example, +IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint. +After unarisation, a single type might correspond to multiple arguments, e.g. + + (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ]) + +will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep] +This means post unarise we potentially have to match up multiple arguments with +the reps of a single argument in the type's definition, because the type of the function +is *not* in unarised form. + Wrinkle: it can sometimes happen that an argument type in the type of the function does not have a fixed runtime representation, i.e. there is an r_i such that runtimeRepPrimRep r_i crashes. @@ -122,7 +131,7 @@ import GHC.Utils.Misc import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform) -import GHC.Core.TyCon (primRepCompatible) +import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) import GHC.Utils.Panic.Plain (panic) lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) @@ -332,14 +341,18 @@ lintStgAppReps fun args = do lf <- getLintFlags let platform = lf_platform lf + (fun_arg_tys, _res) = splitFunTys (idType fun) - fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type] + fun_arg_tys' = map scaledThing fun_arg_tys :: [Type] + + -- Might be "wrongly" typed as polymorphic. See #21399 + -- In these cases typePrimRep_maybe will return Nothing + -- and we abort kind checking. fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]] fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys' actual_arg_reps = map (typePrimRep_maybe . stgArgType) args match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM () - -- Might be wrongly typed as polymorphic. See #21399 match_args (Nothing:_) _ = return () match_args (_) (Nothing:_) = return () match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left) @@ -353,21 +366,36 @@ -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep. -- We check for that here with primRepCompatible - | and $ zipWith (primRepCompatible platform) actual_rep expected_rep + | primRepsCompatible platform actual_rep expected_rep = match_args actual_reps_left expected_reps_left - | otherwise = addErrL $ hang (text "Function type reps and function argument reps missmatched") 2 $ + -- We might distribute args from within one unboxed sum over multiple + -- single rep args. This means we might need to match up things like: + -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]] + -- which happens here. + -- See Note [Linting StgApp]. + | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left + , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left + , primRepCompatible platform actual expected + = match_args actuals expecteds + + | otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $ (text "In application " <> ppr fun <+> ppr args $$ - text "argument rep:" <> ppr actual_rep $$ - text "expected rep:" <> ppr expected_rep $$ + text "argument rep:" <> ppr actual_arg_reps $$ + text "expected rep:" <> ppr fun_arg_tys_reps $$ -- text "expected reps:" <> ppr arg_ty_reps $$ text "unarised?:" <> ppr (lf_unarised lf)) where isVoidRep [] = True isVoidRep [VoidRep] = True isVoidRep _ = False - - -- n_arg_ty_reps = length arg_ty_reps + -- Try to strip one non-void arg rep from the current argument type returning + -- the remaining list of arguments. We return Nothing for invalid input which + -- will result in a lint failure in match_args. + getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]]) + getOneRep [] _rest = Nothing -- Void rep args are invalid at this point. + getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg + getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg. match_args _ _ = return () -- Functions are allowed to be over/under applied. diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -186,6 +186,129 @@ layout to use. Note that unlifted values can't be let-bound, so we don't need types in StgRhsCon. +Note [Casting slot arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this function which selects between Int32# and Int64# from a unboxed sum. + + foo :: (# Int32# | Int64# #) -> FD + foo x = case x of + (# x1 | #) -> F x1 + (# | x2 #) -> D x2 + +Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep. +However we used to generate this (bogus) code after Unarise giving rise to #22208: + + M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD + [GblId, Arity=1, Unf=OtherCon []] = + {} \r [sum_tag sum_field] + case sum_tag of tag_gsc { + __DEFAULT -> M.F [sum_field]; + 2# -> M.D [sum_field]; + }; + +Where sum_field is used both as Int32# and Int64# depending on the branch +because they share the same SlotTy. +This usually works out since we put all int's in the same sort of register. +So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce +correct code in the most cases. +However there are cases where this goes wrong, causing lint errors,in the case of #22208 +compiler panics or in some cases incorrect results in the C backend. +For now our solution is to construct proper casts between the PrimRep of the slot and +the variables we want to store in, or read out of these slots. + +This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32 +we convert it to a Int64 on construction of the tuple value, and convert it back +to a Int32 once when want to use the field. On most backends these coversions should +be no-ops at runtime so this seems reasonable. + +Conversion for values coming out of a strict field happen in mapSumIdBinders. While +conversion during the construction of sums happen inside mkUbxSum. + +------------- A full example of casting during sum construction ---------------- + +To compile a constructor application of a unboxed sum of type (# Int32# | Int64# ) +in an expression like `let sum = (# x | #)` we will call mkUbxSum to determine +which binders we have to replace sum with at use sites during unarise. +See also Note [Translating unboxed sums to unboxed tuples]. + +Int32# and Int64# in this case will share the same slot in the unboxed sum. This means +the sum after unarise will be represented by two binders. One for the tag and one for +the field. The later having Int64Rep. +However our input for the field is of Int32Rep. So in order to soundly construct +`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#. +To do this mkUbxSum will produce an expression with a hole for constructor application +to go into. That is the call to mkUbxSum and it's result will look something like: + + >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x') + ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs ) + +We will use the returned arguments to construct an application to an unboxed tuple: + + >>> mkTuple [tag::Int#, x'::Int64#] + (# tag, x' #) + +Which we will then use as the rhs to pass into the casting wrapper to +construct an expression that casts `x` to the right type before constructing the +tuple + + >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #) + case int32ToInt# x of x' -> (# #) 1# x' + +Which results in the this definition for `sum` after all is said and done: + + let sum = case int32ToInt# x of { x' -> (# #) 1# x' } + +Not that the renaming is not optional. Cmm requires binders of different uniques +to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids + +------------- A full example of casting during sum matching -------------------- + +When matching on an unboxed sum constructor we start out with +something like this the pre-unarise: + + f :: (# Int32 | Int64# ) -> ... + f sum = case sum of + (# x |#) -> alt_rhs + ... + +We unarise the function arguments and get: + + f sum_tag sum_slot1 = case sum_tag of + 1# -> ??? + +Now we need to match up the original alternative binders with the sum slots passed +to the function. This is done by mapSumIdBinders which we we call for our +example alternative like this: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + (env', alt_rhs') + +mapSumIdBinders first matches up the list of binders with the slots passed to +the function which is trivial in this case. Then we check if the slot and the +variable residing inside it agree on their Rep. If alternative binders and +the function arguments agree in their slot reps we we just extend the environment +with a mapping from `x` to `sum_slot1` and we return the rhs as is. + +If the reps of the sum_slots do not agree with alternative binders they represent +then we need to wrap the whole RHS in nested cases which cast the sum_slot +variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be +of Int64Rep. This means instead of retuning the original alt_rhs we will return: + + >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env + ( env'[x=x'] + , case int64ToInt32# (sum_slot1 :: Int64#) of + (x' :: Int32#) -> alt_rhs + ) + +We then run unarise on alt_rhs within that expression, which will replace the first occurence +of `x` with sum_slot_arg_1 giving us post-unarise: + + f sum_tag sum_slot1 = + case sum_tag of + 1# -> case int64ToInt32# sum_slot1 of + x' -> ... x' ... + ... + Note [UnariseEnv] ~~~~~~~~~~~~~~~~~~ At any variable occurrence 'v', @@ -258,8 +381,8 @@ import GHC.Types.Basic import GHC.Core import GHC.Core.DataCon -import GHC.Core.TyCon ( isVoidRep ) -import GHC.Data.FastString (FastString, mkFastString) +import GHC.Core.TyCon +import GHC.Data.FastString (FastString, mkFastString, fsLit) import GHC.Types.Id import GHC.Types.Literal import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID) @@ -268,20 +391,25 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Stg.Utils import GHC.Core.Type import GHC.Builtin.Types.Prim (intPrimTy) import GHC.Builtin.Types import GHC.Types.Unique.Supply +import GHC.Types.Unique import GHC.Utils.Misc import GHC.Types.Var.Env +import GHC.Types.RepType import Data.Bifunctor (second) import Data.Maybe (mapMaybe) import qualified Data.IntMap as IM +import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Casts +import Data.List (mapAccumL) +-- import GHC.Utils.Trace -------------------------------------------------------------------------------- -- | A mapping from binders to the Ids they were expanded/renamed to. @@ -306,8 +434,10 @@ -- INVARIANT: OutStgArgs in the range only have NvUnaryTypes -- (i.e. no unboxed tuples, sums or voids) -- -type UnariseEnv = VarEnv UnariseVal +newtype UnariseEnv = UnariseEnv { ue_rho :: (VarEnv UnariseVal) } +initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv +initUnariseEnv = UnariseEnv data UnariseVal = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void). | UnaryVal OutStgArg -- See NOTE [Renaming during unarisation]. @@ -320,25 +450,27 @@ -- The id is mapped to one or more things. -- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv -extendRho rho x (MultiVal args) +extendRho env x (MultiVal args) = assert (all (isNvUnaryType . stgArgType) args) - extendVarEnv rho x (MultiVal args) -extendRho rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) } +extendRho env x (UnaryVal val) = assert (isNvUnaryType (stgArgType val)) - extendVarEnv rho x (UnaryVal val) + env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) } -- Properly shadow things from an outer scope. -- See Note [UnariseEnv] -- The id stands for itself so we don't record a mapping. -- See Note [UnariseEnv] extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv -extendRhoWithoutValue rho x = delVarEnv rho x +extendRhoWithoutValue env x = env { ue_rho = delVarEnv (ue_rho env) x } +lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal +lookupRho env v = lookupVarEnv (ue_rho env) v -------------------------------------------------------------------------------- unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding] -unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds) +unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds) unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding unariseTopBinding rho (StgTopLifted bind) @@ -366,7 +498,7 @@ unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr unariseExpr rho e@(StgApp f []) - = case lookupVarEnv rho f of + = case lookupRho rho f of Just (MultiVal args) -- Including empty tuples -> return (mkTuple args) Just (UnaryVal (StgVarArg f')) @@ -379,7 +511,7 @@ unariseExpr rho e@(StgApp f args) = return (StgApp f' (unariseFunArgs rho args)) where - f' = case lookupVarEnv rho f of + f' = case lookupRho rho f of Just (UnaryVal (StgVarArg f')) -> f' Nothing -> f err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err) @@ -390,12 +522,17 @@ = return (StgLit l) unariseExpr rho (StgConApp dc n args ty_args) - | Just args' <- unariseMulti_maybe rho dc args ty_args - = return (mkTuple args') - - | otherwise - , let args' = unariseConArgs rho args - = return (StgConApp dc n args' (map stgArgType args')) + | isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args', Just cast_wrapper) + -> return $ cast_wrapper (mkTuple args') + (args', Nothing) + -> return $ (mkTuple args') + | otherwise = + let args' = unariseConArgs rho args in + return $ (StgConApp dc n args' (map stgArgType args')) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) @@ -403,15 +540,19 @@ unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated | StgApp v [] <- scrut - , Just (MultiVal xs) <- lookupVarEnv rho v + , Just (MultiVal xs) <- lookupRho rho v = elimCase rho xs bndr alt_ty alts -- Handle strict lets for tuples and sums: -- case (# a,b #) of r -> rhs -- and analogously for sums | StgConApp dc _n args ty_args <- scrut - , Just args' <- unariseMulti_maybe rho dc args ty_args - = elimCase rho args' bndr alt_ty alts + , isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc + = do + us <- getUniqueSupplyM + case unariseUbxSumOrTupleArgs rho us dc args ty_args of + (args',Just wrapper) -> wrapper <$> elimCase rho args' bndr alt_ty alts + (args',Nothing) -> elimCase rho args' bndr alt_ty alts -- See (3) of Note [Rubbish literals] in GHC.Types.Literal | StgLit lit <- scrut @@ -436,17 +577,21 @@ = StgTick tick <$> unariseExpr rho e -- Doesn't return void args. -unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] -unariseMulti_maybe rho dc args ty_args +unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type] + -> ( [OutStgArg] -- Arguments representing the unboxed sum + , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them + -- into the right Rep +unariseUbxSumOrTupleArgs rho us dc args ty_args | isUnboxedTupleDataCon dc - = Just (unariseConArgs rho args) + = (unariseConArgs rho args, Nothing) | isUnboxedSumDataCon dc , let args1 = assert (isSingleton args) (unariseConArgs rho args) - = Just (mkUbxSum dc ty_args args1) + = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us + in (args2, Just cast_wrapper) | otherwise - = Nothing + = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple" -- Doesn't return void args. unariseRubbish_maybe :: Literal -> Maybe [OutStgArg] @@ -473,15 +618,19 @@ , alt_bndrs = bndrs , alt_rhs = rhs}] = do let rho1 = extendRho rho bndr (MultiVal args) - rho2 + (rho2, rhs') <- case () of + _ | isUnboxedTupleBndr bndr - = mapTupleIdBinders bndrs args rho1 + -> return (mapTupleIdBinders bndrs args rho1, rhs) | otherwise - = assert (isUnboxedSumBndr bndr) $ - if null bndrs then rho1 - else mapSumIdBinders bndrs args rho1 + -> assert (isUnboxedSumBndr bndr) $ + case bndrs of + -- Sum with a void-type binder? + [] -> return (rho1, rhs) + [alt_bndr] -> mapSumIdBinders alt_bndr args rhs rho1 + _ -> pprPanic "mapSumIdBinders" (ppr bndrs $$ ppr args) - unariseExpr rho2 rhs + unariseExpr rho2 rhs' elimCase rho args bndr (MultiValAlt _) alts | isUnboxedSumBndr bndr @@ -572,18 +721,23 @@ unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e} = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args GenStgAlt{ alt_con = DataAlt sumCon +unariseSumAlt rho args alt@GenStgAlt{ alt_con = DataAlt sumCon , alt_bndrs = bs , alt_rhs = e } - = do let rho' = mapSumIdBinders bs args rho - lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) - GenStgAlt lit_case mempty <$> unariseExpr rho' e + = do (rho',e') <- case bs of + [b] -> mapSumIdBinders b args e rho + -- Sums must have one binder + _ -> pprPanic "unariseSumAlt2" (ppr args $$ pprPanicAlt alt) + let lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))) + GenStgAlt lit_case mempty <$> unariseExpr rho' e' + unariseSumAlt _ scrt alt - = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt) + = pprPanic "unariseSumAlt3" (ppr scrt $$ pprPanicAlt alt) -------------------------------------------------------------------------------- +-- Mapping binders when matching und a unboxed sum/tuple mapTupleIdBinders :: [InId] -- Un-processed binders of a tuple alternative. @@ -619,28 +773,91 @@ map_ids rho0 ids_unarised args0 mapSumIdBinders - :: [InId] -- Binder of a sum alternative (remember that sum patterns - -- only have one binder, so this list should be a singleton) + :: InId -- Binder (in the case alternative). -> [OutStgArg] -- Arguments that form the sum (NOT including the tag). -- Can't have void args. - -> UnariseEnv + -> InStgExpr -> UnariseEnv + -> UniqSM (UnariseEnv, OutStgExpr) -mapSumIdBinders [id] args rho0 - = assert (not (any (isZeroBitTy . stgArgType) args)) $ +mapSumIdBinders alt_bndr args rhs rho0 + = assert (not (any (isZeroBitTy . stgArgType) args)) $ do + uss <- listSplitUniqSupply <$> getUniqueSupplyM let + fld_reps = typePrimRep (idType alt_bndr) + + -- Slots representing the whole sum arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args - id_slots = map primRepSlot $ typePrimRep (idType id) + -- The slots representing the field of the sum we bind. + id_slots = map primRepSlot $ fld_reps layout1 = layoutUbxSum arg_slots id_slots - in - if isMultiValBndr id - then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ]) - else assert (layout1 `lengthIs` 1) - extendRho rho0 id (UnaryVal (args !! head layout1)) -mapSumIdBinders ids sum_args _ - = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args) + -- See Note [Casting slot arguments] + -- Most of the code here is just to make sure our binders are of the + -- right type. + -- Select only the args which contain parts of the current field. + id_arg_exprs = [ args !! i | i <- layout1 ] + id_vars = [v | StgVarArg v <- id_arg_exprs] + -- Output types for the field binders based on their rep + id_tys = map primRepToType fld_reps + typed_id_arg_input = assert (equalLength id_vars id_tys) $ + zip3 id_vars id_tys uss + + mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id) + mkCastInput (id,tar_type,bndr_us) = + let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type) + cst_opts = zip3 ops types $ uniqsFromSupply bndr_us + out_id = case cst_opts of + [] -> id + _ -> let (_,ty,uq) = last cst_opts + in mkCastVar uq ty + in (cst_opts,id,out_id) + + cast_inputs = map mkCastInput typed_id_arg_input + (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs + where + cast_arg rhs_in (cast_ops,in_id,out_id) = + let rhs_out = castArgRename cast_ops (StgVarArg in_id) + in (rhs_in . rhs_out, out_id) + + typed_id_args = map StgVarArg typed_ids + + -- pprTrace "mapSumIdBinders" + -- (text "id_tys" <+> ppr id_tys $$ + -- text "id_args" <+> ppr id_arg_exprs $$ + -- text "rhs" <+> ppr rhs $$ + -- text "rhs_with_casts" <+> ppr rhs_with_casts + -- ) $ + if isMultiValBndr alt_bndr + then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs) + else assert (typed_id_args `lengthIs` 1) $ + return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs) + +-- Convert the argument to the given type, and wrap the conversion +-- around the given expression. Use the given Id as a name for the +-- converted value. +castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr +castArgRename ops in_arg rhs = + case ops of + [] -> rhs + ((op,ty,uq):rest_ops) -> + let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty + sub_cast = castArgRename rest_ops (StgVarArg out_id') + in mkCast in_arg op out_id' ty $ sub_cast rhs + +-- Construct a case binder used when casting sums, of a given type and unique. +mkCastVar :: Unique -> Type -> Id +mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq Many ty + +mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr +mkCast arg_in cast_op out_id out_ty in_rhs = + let r2 = typePrimRep1 out_ty + scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty + alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs} + alt_ty = PrimAlt r2 + in (StgCase scrut out_id alt_ty [alt]) + -- | Build a unboxed sum term from arguments of an alternative. -- -- Example, for (# x | #) :: (# (# #) | Int #) we call @@ -652,31 +869,72 @@ -- [ 1#, rubbish ] -- mkUbxSum - :: DataCon -- Sum data con + :: HasDebugCallStack + => DataCon -- Sum data con -> [Type] -- Type arguments of the sum data con -> [OutStgArg] -- Actual arguments of the alternative. - -> [OutStgArg] -- Final tuple arguments -mkUbxSum dc ty_args args0 + -> UniqSupply + -> ([OutStgArg] -- Final tuple arguments + ,(StgExpr->StgExpr) -- We might need to cast the args first + ) +mkUbxSum dc ty_args args0 us = let (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args) - -- drop tag slot - + -- drop tag slot + field_slots = (mapMaybe (typeSlotTy . stgArgType) args0) tag = dataConTag dc + layout' = layoutUbxSum sum_slots field_slots - layout' = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0) tag_arg = StgLitArg (LitNumber LitNumInt (fromIntegral tag)) arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0) - mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg] - mkTupArgs _ [] _ - = [] - mkTupArgs arg_idx (slot : slots_left) arg_map - | Just stg_arg <- IM.lookup arg_idx arg_map - = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map - | otherwise - = ubxSumRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map + ((_idx,_idx_map,_us,wrapper),slot_args) + = assert (length arg_idxs <= length sum_slots ) $ + mapAccumL mkTupArg (0,arg_idxs,us,id) sum_slots + + mkTupArg :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr) + -> SlotTy + -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg) + mkTupArg (arg_idx, arg_map, us, wrapper) slot + | Just stg_arg <- IM.lookup arg_idx arg_map + = case castArg us slot stg_arg of + -- Slot and arg type missmatched, do a cast + Just (casted_arg,us',wrapper') -> + ( (arg_idx+1, arg_map, us', wrapper . wrapper') + , casted_arg) + -- Use the arg as-is + Nothing -> + ( (arg_idx+1, arg_map, us, wrapper) + , stg_arg) + -- Garbage slot, fill with rubbish + | otherwise + = ( (arg_idx+1, arg_map, us, wrapper) + , ubxSumRubbishArg slot) + + castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr) + castArg us slot_ty arg + -- Cast the argument to the type of the slot if required + | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg) + , out_ty <- primRepToType $ slotPrimRep slot_ty + , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty + , not . null $ ops + = let (us1,us2) = splitUniqSupply us + cast_uqs = uniqsFromSupply us1 + cast_opts = zip3 ops types cast_uqs + (_op,out_ty,out_uq) = last cast_opts + casts = castArgRename cast_opts arg :: StgExpr -> StgExpr + in Just (StgVarArg (mkCastVar out_uq out_ty),us2,casts) + -- No need for casting + | otherwise = Nothing + + tup_args = tag_arg : slot_args in - tag_arg : mkTupArgs 0 sum_slots arg_idxs + -- pprTrace "mkUbxSum" ( + -- text "ty_args (slots)" <+> ppr ty_args $$ + -- text "args0" <+> ppr args0 $$ + -- text "wrapper" <+> + -- (ppr $ wrapper $ StgLit $ LitChar '_')) + (tup_args, wrapper) -- | Return a rubbish value for the given slot type. @@ -694,6 +952,8 @@ ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0) +ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep) + where vec_rep = primRepToRuntimeRep (VecRep n e) -------------------------------------------------------------------------------- @@ -787,7 +1047,7 @@ -- | MultiVal a function argument. Never returns an empty list. unariseFunArg :: UnariseEnv -> StgArg -> [StgArg] unariseFunArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (MultiVal []) -> [voidArg] -- NB: do not remove void args Just (MultiVal as) -> as Just (UnaryVal arg) -> [arg] @@ -809,7 +1069,7 @@ -- | MultiVal a DataCon argument. Returns an empty list when argument is void. unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg] unariseConArg rho (StgVarArg x) = - case lookupVarEnv rho x of + case lookupRho rho x of Just (UnaryVal arg) -> [arg] Just (MultiVal as) -> as -- 'as' can be empty Nothing diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -231,8 +231,12 @@ emitAssign :: CmmReg -> CmmExpr -> CmmParse () emitAssign l r = code (F.emitAssign l r) -emitStore :: CmmExpr -> CmmExpr -> CmmParse () -emitStore l r = code (F.emitStore l r) +emitStore :: Maybe MemoryOrdering -> CmmExpr -> CmmExpr -> CmmParse () +emitStore (Just mem_ord) l r = do + platform <- getPlatform + let w = typeWidth $ cmmExprType platform r + emit $ mkUnsafeCall (PrimTarget $ MO_AtomicWrite w mem_ord) [] [l,r] +emitStore Nothing l r = code (F.emitStore l r) getCode :: CmmParse a -> CmmParse CmmAGraph getCode (EC ec) = EC $ \c e s -> do diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -283,9 +283,10 @@ emitAssign (CmmLocal res) currentTSOExpr ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) + emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire) + [ cmmOffsetW platform mutv (fixedHdrSizeW profile) ] - WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do + WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \[] -> do old_val <- CmmLocal <$> newTemp (cmmExprType platform var) emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) @@ -294,8 +295,8 @@ -- Note that this also must come after we read the old value to ensure -- that the read of old_val comes before another core's write to the -- MutVar's value. - emitPrimCall res MO_WriteBarrier [] - emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var + emitPrimCall [] (MO_AtomicWrite (wordWidth platform) MemOrderRelease) + [ cmmOffsetW platform mutv (fixedHdrSizeW profile), var ] platform <- getPlatform mkdirtyMutVarCCall <- getCode $! emitCCall @@ -853,7 +854,7 @@ -- SIMD primops (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do checkVecCompatibility cfg vcat n w - doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res + doVecPackOp ty zeros (replicate n e) res where zeros :: CmmExpr zeros = CmmLit $ CmmVec (replicate n zero) @@ -871,7 +872,7 @@ checkVecCompatibility cfg vcat n w when (es `lengthIsNot` n) $ panic "emitPrimOp: VecPackOp has wrong number of arguments" - doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res + doVecPackOp ty zeros es res where zeros :: CmmExpr zeros = CmmLit $ CmmVec (replicate n zero) @@ -889,14 +890,14 @@ checkVecCompatibility cfg vcat n w when (res `lengthIsNot` n) $ panic "emitPrimOp: VecUnpackOp has wrong number of results" - doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res + doVecUnpackOp ty arg res where ty :: CmmType ty = vecVmmType vcat n w (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do checkVecCompatibility cfg vcat n w - doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res + doVecInsertOp ty v e i res where ty :: CmmType ty = vecVmmType vcat n w @@ -2247,32 +2248,8 @@ vecCmmCat WordVec = cmmBits vecCmmCat FloatVec = cmmFloat -vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemInjectCast _ FloatVec _ = Nothing -vecElemInjectCast platform IntVec W8 = Just (mo_WordTo8 platform) -vecElemInjectCast platform IntVec W16 = Just (mo_WordTo16 platform) -vecElemInjectCast platform IntVec W32 = Just (mo_WordTo32 platform) -vecElemInjectCast _ IntVec W64 = Nothing -vecElemInjectCast platform WordVec W8 = Just (mo_WordTo8 platform) -vecElemInjectCast platform WordVec W16 = Just (mo_WordTo16 platform) -vecElemInjectCast platform WordVec W32 = Just (mo_WordTo32 platform) -vecElemInjectCast _ WordVec W64 = Nothing -vecElemInjectCast _ _ _ = Nothing - -vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp -vecElemProjectCast _ FloatVec _ = Nothing -vecElemProjectCast platform IntVec W8 = Just (mo_s_8ToWord platform) -vecElemProjectCast platform IntVec W16 = Just (mo_s_16ToWord platform) -vecElemProjectCast platform IntVec W32 = Just (mo_s_32ToWord platform) -vecElemProjectCast _ IntVec W64 = Nothing -vecElemProjectCast platform WordVec W8 = Just (mo_u_8ToWord platform) -vecElemProjectCast platform WordVec W16 = Just (mo_u_16ToWord platform) -vecElemProjectCast platform WordVec W32 = Just (mo_u_32ToWord platform) -vecElemProjectCast _ WordVec W64 = Nothing -vecElemProjectCast _ _ _ = Nothing - - --- NOTE [SIMD Design for the future] +-- Note [SIMD Design for the future] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Check to make sure that we can generate code for the specified vector type -- given the current set of dynamic flags. -- Currently these checks are specific to x86 and x86_64 architecture. @@ -2333,13 +2310,12 @@ ------------------------------------------------------------------------------ -- Helpers for translating vector packing and unpacking. -doVecPackOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Type of vector +doVecPackOp :: CmmType -- Type of vector -> CmmExpr -- Initial vector -> [CmmExpr] -- Elements -> CmmFormal -- Destination for result -> FCode () -doVecPackOp maybe_pre_write_cast ty z es res = do +doVecPackOp ty z es res = do dst <- newTemp ty emitAssign (CmmLocal dst) z vecPack dst es 0 @@ -2352,31 +2328,25 @@ dst <- newTemp ty if isFloatType (vecElemType ty) then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) + [CmmReg (CmmLocal src), e, iLit]) else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid) - [CmmReg (CmmLocal src), cast e, iLit]) + [CmmReg (CmmLocal src), e, iLit]) vecPack dst es (i + 1) where -- vector indices are always 32-bits iLit = CmmLit (CmmInt (toInteger i) W32) - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - len :: Length len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) -doVecUnpackOp :: Maybe MachOp -- Cast from vector component to element result - -> CmmType -- Type of vector +doVecUnpackOp :: CmmType -- Type of vector -> CmmExpr -- Vector -> [CmmFormal] -- Element results -> FCode () -doVecUnpackOp maybe_post_read_cast ty e res = +doVecUnpackOp ty e res = vecUnpack res 0 where vecUnpack :: [CmmFormal] -> Int -> FCode () @@ -2385,46 +2355,36 @@ vecUnpack (r : rs) i = do if isFloatType (vecElemType ty) - then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid) - [e, iLit])) - else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid) - [e, iLit])) + then emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid) + [e, iLit]) + else emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid) + [e, iLit]) vecUnpack rs (i + 1) where -- vector indices are always 32-bits iLit = CmmLit (CmmInt (toInteger i) W32) - cast :: CmmExpr -> CmmExpr - cast val = case maybe_post_read_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] - len :: Length len = vecLength ty wid :: Width wid = typeWidth (vecElemType ty) -doVecInsertOp :: Maybe MachOp -- Cast from element to vector component - -> CmmType -- Vector type +doVecInsertOp :: CmmType -- Vector type -> CmmExpr -- Source vector -> CmmExpr -- Element -> CmmExpr -- Index at which to insert element -> CmmFormal -- Destination for result -> FCode () -doVecInsertOp maybe_pre_write_cast ty src e idx res = do +doVecInsertOp ty src e idx res = do platform <- getPlatform -- vector indices are always 32-bits let idx' :: CmmExpr idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx] if isFloatType (vecElemType ty) - then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx']) - else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx']) + then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx']) + else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx']) where - cast :: CmmExpr -> CmmExpr - cast val = case maybe_pre_write_cast of - Nothing -> val - Just cast -> CmmMachOp cast [val] len :: Length len = vecLength ty @@ -3081,7 +3041,7 @@ doAtomicReadAddr res addr ty = emitPrimCall [ res ] - (MO_AtomicRead (typeWidth ty)) + (MO_AtomicRead (typeWidth ty) MemOrderSeqCst) [ addr ] -- | Emit an atomic write to a byte array that acts as a memory barrier. @@ -3109,7 +3069,7 @@ doAtomicWriteAddr addr ty val = emitPrimCall [ {- no results -} ] - (MO_AtomicWrite (typeWidth ty)) + (MO_AtomicWrite (typeWidth ty) MemOrderSeqCst) [ addr, val ] doCasByteArray diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -170,11 +170,7 @@ getResponseFile args = do fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do -#if defined(mingw32_HOST_OS) - hSetEncoding h latin1 -#else hSetEncoding h utf8 -#endif hPutStr h $ unlines $ map escape args return fp diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -172,7 +172,7 @@ } } } where needs_typeable_binds tc - | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon] + | tc `elem` ghcTypesTypeableTyCons = False | otherwise = isAlgTyCon tc @@ -333,7 +333,14 @@ -- Build TypeRepTodos for types in GHC.Prim ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id ghcPrimTypeableTyCons - ; return ( gbl_env' , [todo1, todo2]) + ; tcg_env <- getGblEnv + ; let mod_id = case tcg_tr_module tcg_env of -- Should be set by now + Just mod_id -> mod_id + Nothing -> pprPanic "tcMkTypeableBinds" empty + + ; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons + + ; return ( gbl_env' , [todo1, todo2, todo3]) } else do gbl_env <- getGblEnv return (gbl_env, []) @@ -348,11 +355,17 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat - [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ] - , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] + [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] , map sumTyCon [2..mAX_SUM_SIZE] , primTyCons ] + +-- | These are types which are defined in GHC.Types but are needed in order to +-- typecheck the other generated bindings, therefore to avoid ordering issues we +-- generate them up-front along with the bindings from GHC.Prim. +ghcTypesTypeableTyCons :: [TyCon] +ghcTypesTypeableTyCons = [ runtimeRepTyCon, levityTyCon + , vecCountTyCon, vecElemTyCon ] data TypeableStuff = Stuff { platform :: Platform -- ^ Target platform diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -136,13 +136,13 @@ -- that package is searched for the module. findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult -findImportedModule hsc_env mod fs = +findImportedModule hsc_env mod pkg_qual = let fc = hsc_FC hsc_env mhome_unit = hsc_home_unit_maybe hsc_env dflags = hsc_dflags hsc_env fopts = initFinderOpts dflags in do - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual findImportedModuleNoHsc :: FinderCache diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib -version: 9.4.3.20221104 +version: 9.4.4.20221225 license: BSD3 license-file: LICENSE category: Development @@ -83,7 +83,7 @@ stm, rts, hpc == 0.6.*, - ghc-lib-parser == 9.4.3.20221104 + ghc-lib-parser == 9.4.4.20221225 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns @@ -477,6 +477,7 @@ Paths_ghc_lib GHC GHC.Builtin.Names.TH + GHC.Builtin.PrimOps.Casts GHC.Builtin.Types.Literals GHC.Builtin.Utils GHC.ByteCode.Asm diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -656,16 +656,16 @@ primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#") [] [int16PrimTy] (int16X32PrimTy) primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#") [] [int32PrimTy] (int32X16PrimTy) primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#") [] [int64PrimTy] (int64X8PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [wordPrimTy] (word8X16PrimTy) -primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [wordPrimTy] (word16X8PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#") [] [word8PrimTy] (word8X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#") [] [word16PrimTy] (word16X8PrimTy) primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#") [] [word32PrimTy] (word32X4PrimTy) primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#") [] [word64PrimTy] (word64X2PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [wordPrimTy] (word8X32PrimTy) -primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [wordPrimTy] (word16X16PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#") [] [word8PrimTy] (word8X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#") [] [word16PrimTy] (word16X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#") [] [word32PrimTy] (word32X8PrimTy) primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#") [] [word64PrimTy] (word64X4PrimTy) -primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [wordPrimTy] (word8X64PrimTy) -primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [wordPrimTy] (word16X32PrimTy) +primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#") [] [word8PrimTy] (word8X64PrimTy) +primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#") [] [word16PrimTy] (word16X32PrimTy) primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#") [] [word32PrimTy] (word32X16PrimTy) primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#") [] [word64PrimTy] (word64X8PrimTy) primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#") [] [floatPrimTy] (floatX4PrimTy) @@ -686,16 +686,16 @@ primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#") [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy) primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#") [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy) primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#") [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X8PrimTy) -primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy) -primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy) +primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#") [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X16PrimTy) +primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#") [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X8PrimTy) primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy) primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy])] (word64X2PrimTy) -primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy) -primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy) +primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#") [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X32PrimTy) +primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#") [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X16PrimTy) primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy) primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X4PrimTy) -primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy) -primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy) +primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#") [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X64PrimTy) +primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#") [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X32PrimTy) primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#") [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy) primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#") [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X8PrimTy) primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#") [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy) @@ -716,16 +716,16 @@ primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#") [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])) primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#") [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])) primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#") [] [int64X8PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#") [] [word8X16PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])) +primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#") [] [word16X8PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])) primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#") [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#") [] [word64X2PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#") [] [word8X32PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])) +primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#") [] [word16X16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])) primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#") [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#") [] [word64X4PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) -primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) -primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])) +primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#") [] [word8X64PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])) +primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#") [] [word16X32PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])) primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#") [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])) primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#") [] [word64X8PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])) primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#") [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])) @@ -746,16 +746,16 @@ primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#") [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy) primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#") [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy) primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#") [] [int64X8PrimTy, int64PrimTy, intPrimTy] (int64X8PrimTy) -primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy) -primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy) +primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#") [] [word8X16PrimTy, word8PrimTy, intPrimTy] (word8X16PrimTy) +primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#") [] [word16X8PrimTy, word16PrimTy, intPrimTy] (word16X8PrimTy) primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#") [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy) primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#") [] [word64X2PrimTy, word64PrimTy, intPrimTy] (word64X2PrimTy) -primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy) -primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy) +primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#") [] [word8X32PrimTy, word8PrimTy, intPrimTy] (word8X32PrimTy) +primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#") [] [word16X16PrimTy, word16PrimTy, intPrimTy] (word16X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#") [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy) primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#") [] [word64X4PrimTy, word64PrimTy, intPrimTy] (word64X4PrimTy) -primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy) -primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy) +primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#") [] [word8X64PrimTy, word8PrimTy, intPrimTy] (word8X64PrimTy) +primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#") [] [word16X32PrimTy, word16PrimTy, intPrimTy] (word16X32PrimTy) primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#") [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy) primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#") [] [word64X8PrimTy, word64PrimTy, intPrimTy] (word64X8PrimTy) primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#") [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)