Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 6 Feb 2013 12:54:33 +0000 (12:54 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 6 Feb 2013 12:54:33 +0000 (12:54 +0000)
186 files changed:
.gitignore
.gitmodules
aclocal.m4
compiler/basicTypes/BasicTypes.lhs
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/Demand.lhs
compiler/basicTypes/IdInfo.lhs
compiler/basicTypes/MkId.lhs
compiler/basicTypes/SrcLoc.lhs
compiler/basicTypes/Var.lhs
compiler/cmm/CLabel.hs
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmCommonBlockElim.hs
compiler/cmm/CmmExpr.hs
compiler/cmm/CmmLex.x
compiler/cmm/CmmMachOp.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmType.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/PprC.hs
compiler/cmm/PprCmmExpr.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmPrim.hs
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/PprCore.lhs
compiler/coreSyn/PprExternalCore.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/MatchLit.lhs
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeItbls.lhs
compiler/ghci/ByteCodeLink.lhs
compiler/ghci/LibFFI.hsc
compiler/ghci/Linker.lhs
compiler/hsSyn/HsDecls.lhs
compiler/hsSyn/HsExpr.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/llvmGen/Llvm.hs
compiler/llvmGen/Llvm/AbsSyn.hs
compiler/llvmGen/Llvm/PpLlvm.hs
compiler/llvmGen/Llvm/Types.hs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/llvmGen/LlvmCodeGen/Data.hs
compiler/llvmGen/LlvmCodeGen/Regs.hs
compiler/main/DriverMkDepend.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/DynamicLoading.hs
compiler/main/ErrUtils.lhs
compiler/main/GHC.hs
compiler/main/GhcMake.hs
compiler/main/HscTypes.lhs
compiler/main/InteractiveEval.hs
compiler/main/Packages.lhs
compiler/main/StaticFlags.hs
compiler/main/SysTools.lhs
compiler/main/TidyPgm.lhs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/PPC/CodeGen.hs
compiler/nativeGen/PPC/Instr.hs
compiler/nativeGen/SPARC/CodeGen.hs
compiler/nativeGen/X86/CodeGen.hs
compiler/parser/Parser.y.pp
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/primops.txt.pp
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnSource.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stgSyn/StgLint.lhs
compiler/stgSyn/StgSyn.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcUnify.lhs
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/InstEnv.lhs
compiler/types/OptCoercion.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/utils/Exception.hs
compiler/utils/Panic.lhs
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Convert.hs
compiler/vectorise/Vectorise/Env.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Monad.hs
compiler/vectorise/Vectorise/Monad/Global.hs
compiler/vectorise/Vectorise/Monad/InstEnv.hs
compiler/vectorise/Vectorise/Monad/Local.hs
compiler/vectorise/Vectorise/Type/Classify.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/Type.hs
compiler/vectorise/Vectorise/Utils.hs
configure.ac
distrib/configure.ac.in
distrib/mkDocs/mkDocs [changed mode: 0644->0755]
docs/storage-mgt/rp.tex
docs/users_guide/glasgow_exts.xml
docs/users_guide/parallel.xml
docs/users_guide/phases.xml
docs/users_guide/safe_haskell.xml
docs/users_guide/using.xml
ghc.mk
ghc/InteractiveUI.hs
includes/Cmm.h
includes/CodeGen.Platform.hs
includes/Rts.h
includes/rts/Ticky.h
includes/rts/storage/FunTypes.h
includes/rts/storage/TSO.h
includes/stg/HaskellMachRegs.h
includes/stg/MachRegs.h
includes/stg/MiscClosures.h
includes/stg/Regs.h
includes/stg/RtsMachRegs.h
includes/stg/Types.h
libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs
libraries/gen_contents_index
libraries/random [new submodule]
mk/config.mk.in
packages
rts/Linker.c
rts/STM.c
rts/Schedule.h
rts/StgMiscClosures.cmm
rts/posix/OSMem.c
rts/win32/AsyncIO.c
rts/win32/AsyncIO.h
rts/win32/IOManager.c
rts/win32/IOManager.h
rules/add-dependency.mk [new file with mode: 0644]
rules/build-prog.mk
utils/deriveConstants/DeriveConstants.hs
utils/genapply/GenApply.hs
utils/genprimopcode/Main.hs
utils/ghc-cabal/ghc.mk
utils/ghc-pkg/ghc.mk
utils/hp2ps/ghc.mk

index 256d538..829f19a 100644 (file)
@@ -62,7 +62,6 @@ _darcs/
 /libraries/old-time/
 /libraries/parallel/
 /libraries/process/
-/libraries/random/
 /libraries/stm/
 /libraries/template-haskell/
 /libraries/unix/
index 5befbfc..72303a8 100644 (file)
@@ -37,3 +37,6 @@
 [submodule "libraries/time"]
        path = libraries/time
        url = http://darcs.haskell.org/libraries/time.git/
+[submodule "libraries/random"]
+       path = libraries/random
+       url = http://darcs.haskell.org/libraries/random.git/
index 7b185b9..0fe79cf 100644 (file)
@@ -379,10 +379,12 @@ AC_DEFUN([GET_ARM_ISA],
                         )],
                         [changequote(, )dnl
                          ARM_ISA_EXT="[VFPv2]"
-                         changequote([, ])dnl],
+                         changequote([, ])dnl
+                        ],
                         [changequote(, )dnl
                          ARM_ISA_EXT="[]"
-                         changequote([, ])dnl]
+                         changequote([, ])dnl
+                        ]
                 )],
                 [changequote(, )dnl
                  ARM_ISA=ARMv7
@@ -390,6 +392,33 @@ AC_DEFUN([GET_ARM_ISA],
                  changequote([, ])dnl
                 ])
         ])
+
+        AC_COMPILE_IFELSE(
+               [AC_LANG_PROGRAM(
+                       [],
+                       [#if defined(__SOFTFP__)
+                            return 0;
+                       #else
+                            not softfp
+                       #endif]
+               )],
+               [changequote(, )dnl
+                ARM_ABI="SOFT"
+                changequote([, ])dnl
+               ],
+               [AC_COMPILE_IFELSE(
+                    [AC_LANG_PROGRAM(
+                       [],
+                       [#if defined(__ARM_PCS_VFP)
+                            return 0;
+                       #else
+                            no hard float ABI
+                       #endif]
+                    )],
+                    [ARM_ABI="HARD"],
+                    [ARM_ABI="SOFTFP"]
+               )]
+        )
 ])
 
 
index be6a78f..a4fb559 100644 (file)
@@ -26,6 +26,8 @@ types that
 module BasicTypes(
        Version, bumpVersion, initialVersion,
 
+        ConTag, fIRST_TAG,
+
        Arity, RepArity,
        
        Alignment,
@@ -113,6 +115,21 @@ type RepArity = Int
 
 %************************************************************************
 %*                                                                     *
+              Constructor tags
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | Type of the tags associated with each constructor possibility
+type ConTag = Int
+
+fIRST_TAG :: ConTag
+-- ^ Tags are allocated from here for real constructors
+fIRST_TAG =  1
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection[Alignment]{Alignment}
 %*                                                                     *
 %************************************************************************
index a0cc4bd..2b96d3f 100644 (file)
@@ -42,9 +42,6 @@ module DataCon (
        isVanillaDataCon, classDataCon, dataConCannotMatch,
         isBanged, isMarkedStrict, eqHsBang,
 
-        -- * Splitting product types
-       splitProductType_maybe, splitProductType, 
-
         -- ** Promotion related functions
         promoteKind, promoteDataCon, promoteDataCon_maybe
     ) where
@@ -463,13 +460,6 @@ data HsBang
 -- StrictnessMark is internal only, used to indicate strictness 
 -- of the DataCon *worker* fields
 data StrictnessMark = MarkedStrict | NotMarkedStrict   
-
--- | Type of the tags associated with each constructor possibility
-type ConTag = Int
-
-fIRST_TAG :: ConTag
--- ^ Tags are allocated from here for real constructors
-fIRST_TAG =  1
 \end{code}
 
 Note [Data con representation]
@@ -1029,56 +1019,6 @@ buildAlgTyCon tc_name ktvs cType stupid_theta rhs
 
 
 %************************************************************************
-%*                                                                     *
-\subsection{Splitting products}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
--- | Extract the type constructor, type argument, data constructor and it's
--- /representation/ argument types from a type if it is a product type.
---
--- Precisely, we return @Just@ for any type that is all of:
---
---  * Concrete (i.e. constructors visible)
---
---  * Single-constructor
---
---  * Not existentially quantified
---
--- Whether the type is a @data@ type or a @newtype@
-splitProductType_maybe
-       :: Type                         -- ^ A product type, perhaps
-       -> Maybe (TyCon,                -- The type constructor
-                 [Type],               -- Type args of the tycon
-                 DataCon,              -- The data constructor
-                 [Type])               -- Its /representation/ arg types
-
-       -- Rejecing existentials is conservative.  Maybe some things
-       -- could be made to work with them, but I'm not going to sweat
-       -- it through till someone finds it's important.
-
-splitProductType_maybe ty
-  = case splitTyConApp_maybe ty of
-       Just (tycon,ty_args)
-          | isProductTyCon tycon       -- Includes check for non-existential,
-                                       -- and for constructors visible
-          -> Just (tycon, ty_args, data_con, dataConInstArgTys data_con ty_args)
-          where
-             data_con = ASSERT( not (null (tyConDataCons tycon)) ) 
-                        head (tyConDataCons tycon)
-       _other -> Nothing
-
--- | As 'splitProductType_maybe', but panics if the 'Type' is not a product type
-splitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
-splitProductType str ty
-  = case splitProductType_maybe ty of
-       Just stuff -> stuff
-       Nothing    -> pprPanic (str ++ ": not a product") (pprType ty)
-\end{code}
-
-
-%************************************************************************
 %*                                                                      *
         Promoting of data types to the kind level
 %*                                                                      *
index ad778d1..5d78036 100644 (file)
@@ -20,11 +20,12 @@ module Demand (
 
         DmdEnv, emptyDmdEnv,
 
-        DmdResult, CPRResult, PureResult, 
+        DmdResult, CPRResult,
         isBotRes, isTopRes, resTypeArgDmd, 
-        topRes, botRes, cprRes,
-        appIsBottom, isBottomingSig, pprIfaceStrictSig, returnsCPR, 
-        StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
+        topRes, botRes, cprProdRes, cprSumRes,
+        appIsBottom, isBottomingSig, pprIfaceStrictSig, 
+        returnsCPR, returnsCPRProd, returnsCPR_maybe,
+        StrictSig(..), mkStrictSig, topSig, botSig, cprProdSig,
         isTopSig, splitStrictSig, increaseStrictSigArity,
        
         seqStrDmd, seqStrDmdList, seqAbsDmd, seqAbsDmdList,
@@ -48,44 +49,24 @@ import UniqFM
 import Util
 import BasicTypes
 import Binary
-import Maybes                    ( expectJust )
+import Maybes                    ( isJust, expectJust )
 \end{code}
 
 %************************************************************************
 %*                                                                      *
-\subsection{Lattice-like structure for domains}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-
-class LatticeLike a where
-  bot    :: a
-  top    :: a
-  pre    :: a -> a -> Bool
-  lub    :: a -> a -> a 
-  both   :: a -> a -> a
-
--- False < True
-instance LatticeLike Bool where
-  bot     = False
-  top     = True
--- x `pre` y <==> (x => y)
-  pre x y = (not x) || y  
-  lub     = (||)
-  both    = (&&)
-
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
 \subsection{Strictness domain}
 %*                                                                      *
 %************************************************************************
 
-\begin{code}
+        Lazy
+         |
+        Str
+      /     \
+  SCall      SProd
+      \      /
+      HyperStr
 
+\begin{code}
 -- Vanilla strictness domain
 data StrDmd
   = HyperStr             -- Hyper-strict 
@@ -132,42 +113,43 @@ instance Outputable StrDmd where
   ppr Str           = char 'S'
   ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))
 
--- LatticeLike implementation for strictness demands
-instance LatticeLike StrDmd where
-  bot = HyperStr
-  top = Lazy
-  
-  pre _ Lazy                               = True
-  pre HyperStr _                           = True
-  pre (SCall s1) (SCall s2)                = pre s1 s2
-  pre (SCall _) Str                        = True
-  pre (SProd _) Str                        = True
-  pre (SProd sx1) (SProd sx2)    
-            | length sx1 == length sx2     = all (== True) $ zipWith pre sx1 sx2 
-  pre x y                                  = x == y
-
-  lub x y | x == y                         = x 
-  lub y x | x `pre` y                      = lub x y
-  lub HyperStr s                           = s
-  lub _ Lazy                               = strTop
-  lub (SProd _) Str                        = strStr
-  lub (SProd sx1) (SProd sx2) 
-           | length sx1 == length sx2      = strProd $ zipWith lub sx1 sx2
-           | otherwise                     = strStr
-  lub (SCall s1) (SCall s2)                = strCall (s1 `lub` s2)
-  lub (SCall _)  Str                       = strStr
-  lub _ _                                  = strTop
-
-  both x y | x == y                        = x 
-  both y x | x `pre` y                     = both x y
-  both HyperStr _                          = strBot
-  both s Lazy                              = s
-  both s@(SProd _) Str                     = s
-  both (SProd sx1) (SProd sx2) 
-           | length sx1 == length sx2      = strProd $ zipWith both sx1 sx2 
-  both (SCall s1) (SCall s2)               = strCall (s1 `both` s2)
-  both s@(SCall _)  Str                    = s
-  both _ _                                 = strBot
+lubStr :: StrDmd -> StrDmd -> StrDmd
+lubStr HyperStr s              = s
+lubStr (SCall s1) HyperStr     = SCall s1
+lubStr (SCall _)  Lazy         = Lazy
+lubStr (SCall _)  Str          = Str
+lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)
+lubStr (SCall _)  (SProd _)    = Str
+lubStr (SProd _)  HyperStr     = HyperStr
+lubStr (SProd _)  Lazy         = Lazy
+lubStr (SProd _)  Str          = Str
+lubStr (SProd s1) (SProd s2)
+    | length s1 == length s2   = SProd (zipWith lubStr s1 s2)
+    | otherwise                = Str
+lubStr (SProd _) (SCall _)     = Str
+lubStr Str Lazy                = Lazy
+lubStr Str _                   = Str
+lubStr Lazy _                  = Lazy
+
+bothStr :: StrDmd -> StrDmd -> StrDmd
+bothStr HyperStr _             = HyperStr
+bothStr Lazy s                 = s
+bothStr Str Lazy               = Str
+bothStr Str s                  = s
+bothStr (SCall _)  HyperStr    = HyperStr
+bothStr (SCall s1) Lazy        = SCall s1
+bothStr (SCall s1) Str         = SCall s1
+bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)
+bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird
+
+bothStr (SProd _)  HyperStr    = HyperStr
+bothStr (SProd s1) Lazy        = SProd s1
+bothStr (SProd s1)  Str        = SProd s1
+bothStr (SProd s1) (SProd s2) 
+    | length s1 == length s2   = SProd (zipWith bothStr s1 s2)
+    | otherwise                = HyperStr  -- Weird
+bothStr (SProd _) (SCall _)    = HyperStr
+
 
 -- utility functions to deal with memory leaks
 seqStrDmd :: StrDmd -> ()
@@ -179,6 +161,10 @@ seqStrDmdList :: [StrDmd] -> ()
 seqStrDmdList [] = ()
 seqStrDmdList (d:ds) = seqStrDmd d `seq` seqStrDmdList ds
 
+isStrict :: StrDmd -> Bool
+isStrict Lazy = False
+isStrict _    = True
+
 -- Splitting polymorphic demands
 splitStrProdDmd :: Int -> StrDmd -> [StrDmd]
 splitStrProdDmd n Lazy         = replicate n Lazy
@@ -196,7 +182,7 @@ splitStrProdDmd n (SCall d)    = ASSERT( n == 1 ) [d]
 
 Note [Don't optimise UProd(Used) to Used]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An AbsDmds
+These two AbsDmds:
    UProd [Used, Used]   and    Used
 are semantically equivalent, but we do not turn the former into
 the latter, for a regrettable-subtle reason.  Suppose we did.
@@ -214,14 +200,29 @@ This too would get <Str, Used>, but this time there really isn't any
 point in w/w since the components of the pair are not used at all.
 
 So the solution is: don't collapse UProd [Used,Used] to Used; intead
-leave it as-is.  
-    
+leave it as-is. In effect we are using the AbsDmd to do a little bit
+of boxity analysis.  Not very nice.
+
+
+      Used
+      /   \
+  UCall   UProd
+      \   /
+      UHead
+       |
+      Abs
 
 \begin{code}
 data AbsDmd
   = Abs                  -- Definitely unused
                          -- Bottom of the lattice
 
+  | UHead                -- May be used; but its sub-components are 
+                         -- definitely *not* used.  Roughly U(AAA)
+                         -- Eg the usage of x in x `seq` e
+                         -- A polymorphic demand: used for values of all types,
+                         --                       including a type variable
+
   | UCall AbsDmd         -- Call demand for absence
                          -- Used only for values of function type
 
@@ -231,12 +232,6 @@ data AbsDmd
                          -- [Invariant] Not all components are Abs
                          --             (in that case, use UHead)
 
-  | UHead                -- May be used; but its sub-components are 
-                         -- definitely *not* used.  
-                         -- Eg the usage of x in x `seq` e
-                         -- A polymorphic demand: used for values of all types,
-                         --                       including a type variable
-
   | Used                 -- May be used; and its sub-components may be used
                          -- Top of the lattice
   deriving ( Eq, Show )
@@ -267,32 +262,26 @@ absProd ux
   | all (== Abs) ux    = UHead
   | otherwise          = UProd ux
 
-instance LatticeLike AbsDmd where
-  bot                            = absBot
-  top                            = absTop
-  pre Abs _                      = True
-  pre _ Used                     = True
-  pre UHead (UProd _)            = True
-  pre (UCall u1) (UCall u2)      = pre u1 u2
-  pre (UProd ux1) (UProd ux2)
-     | length ux1 == length ux2  = all (== True) $ zipWith pre ux1 ux2 
-  pre x y                        = x == y
-
-  lub x y | x == y               = x 
-  lub y x | x `pre` y            = lub x y
-  lub Abs a                      = a
-  lub a Abs                      = a
-  lub UHead u                    = u
-  lub u UHead                    = u
-  lub (UProd ux1) (UProd ux2)
-     | length ux1 == length ux2  = absProd $ zipWith lub ux1 ux2
-  lub (UCall u1) (UCall u2)      = absCall (u1 `lub` u2)
-  lub (UProd ds) Used            = UProd (map (`lub` Used) ds)
-  lub Used (UProd ds)            = UProd (map (`lub` Used) ds)
-  lub _ _                        = Used
-
-  both                           = lub
+lubAbs :: AbsDmd -> AbsDmd -> AbsDmd
+lubAbs Abs   x               = x
+lubAbs UHead Abs             = UHead
+lubAbs UHead x               = x         
+lubAbs (UCall u1) Abs        = UCall u1 
+lubAbs (UCall u1) UHead      = UCall u1 
+lubAbs (UCall u1) (UCall u2) = UCall (u1 `lubAbs` u2)
+lubAbs (UCall _)  _          = Used
+lubAbs (UProd u1) Abs        = UProd u1 
+lubAbs (UProd u1) UHead      = UProd u1 
+lubAbs (UProd u1) (UProd u2)
+   | length u1 == length u2  = UProd (zipWith lubAbs u1 u2)
+   | otherwise               = Used
+lubAbs (UProd _) (UCall _)   = Used
+lubAbs (UProd ds) Used       = UProd (map (`lubAbs` Used) ds)  -- Note [Don't optimise UProd(Used) to Used]
+lubAbs Used (UProd ds)       = UProd (map (`lubAbs` Used) ds)  -- Note [Don't optimise UProd(Used) to Used]
+lubAbs Used  _               = Used
+
+bothAbs :: AbsDmd -> AbsDmd -> AbsDmd
+bothAbs = lubAbs
 
 -- utility functions
 seqAbsDmd :: AbsDmd -> ()
@@ -345,33 +334,22 @@ mkProdDmd dx
     sp = strProd $ map strd dx
     up = absProd $ map absd dx   
      
-instance LatticeLike JointDmd where
-  bot  = botDmd
-  top  = topDmd
-  pre  = preDmd
-  lub  = lubDmd
-  both = bothDmd
-
 absDmd :: JointDmd
-absDmd = mkJointDmd top bot 
+absDmd = mkJointDmd strTop absBot
 
 topDmd :: JointDmd
-topDmd = mkJointDmd top top
+topDmd = mkJointDmd strTop absTop
 
 botDmd :: JointDmd
-botDmd = mkJointDmd bot bot
-
-preDmd :: JointDmd -> JointDmd -> Bool
-preDmd (JD {strd = s1, absd = a1}) 
-       (JD {strd = s2, absd = a2})  = pre s1 s2 && pre a1 a2
+botDmd = mkJointDmd strBot absBot
 
 lubDmd :: JointDmd -> JointDmd -> JointDmd
 lubDmd (JD {strd = s1, absd = a1}) 
-       (JD {strd = s2, absd = a2}) = mkJointDmd (lub s1 s2) (lub a1 a2)
+       (JD {strd = s2, absd = a2}) = mkJointDmd (lubStr s1 s2) (lubAbs a1 a2)
 
 bothDmd :: JointDmd -> JointDmd -> JointDmd
 bothDmd (JD {strd = s1, absd = a1}) 
-        (JD {strd = s2, absd = a2}) = mkJointDmd (both s1 s2) (both a1 a2)
+        (JD {strd = s2, absd = a2}) = mkJointDmd (bothStr s1 s2) (bothAbs a1 a2)
 
 isTopDmd :: JointDmd -> Bool
 isTopDmd (JD {strd = Lazy, absd = Used}) = True
@@ -398,13 +376,13 @@ seqDemandList [] = ()
 seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds
 
 isStrictDmd :: Demand -> Bool
-isStrictDmd (JD {strd = x}) = x /= top
+isStrictDmd (JD {strd = x}) = isStrict x
 
 isUsedDmd :: Demand -> Bool
-isUsedDmd (JD {absd = x}) = x /= bot
+isUsedDmd (JD {absd = x}) = isUsed x
 
 isUsed :: AbsDmd -> Bool
-isUsed x = x /= bot
+isUsed x = x /= absBot
 
 someCompUsed :: AbsDmd -> Bool
 someCompUsed Used      = True
@@ -416,7 +394,7 @@ evalDmd :: JointDmd
 evalDmd = mkJointDmd strStr absTop
 
 defer :: Demand -> Demand
-defer (JD {absd = a}) = mkJointDmd top a 
+defer (JD {absd = a}) = mkJointDmd strTop a 
 
 -- use :: Demand -> Demand
 -- use (JD {strd = d}) = mkJointDmd d top
@@ -424,7 +402,6 @@ defer (JD {absd = a}) = mkJointDmd top a
 
 Note [Dealing with call demands]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
 Call demands are constructed and deconstructed coherently for
 strictness and absence. For instance, the strictness signature for the
 following function
@@ -436,8 +413,7 @@ should be: <L,C(U(AU))>m
 
 \begin{code}
 mkCallDmd :: JointDmd -> JointDmd
-mkCallDmd (JD {strd = d, absd = a}) 
-          = mkJointDmd (strCall d) (absCall a)
+mkCallDmd (JD {strd = d, absd = a}) = mkJointDmd (strCall d) (absCall a)
 
 peelCallDmd :: JointDmd -> Maybe JointDmd
 -- Exploiting the fact that 
@@ -528,109 +504,91 @@ isProdDmd _                     = False
 %************************************************************************
 
 \begin{code}
-
 ------------------------------------------------------------------------
--- Pure demand result                                             
+-- Constructed Product Result                                             
 ------------------------------------------------------------------------
 
-data PureResult = TopRes        -- Nothing known, assumed to be just lazy
-                | BotRes        -- Diverges or errors
+data CPRResult = NoCPR              -- Top of the lattice
+               | RetProd            -- Returns a constructor from a product type
+               | RetSum ConTag      -- Returns a constructor from a sum type with this tag
+               | BotCPR             -- Returns a constructor with any tag
+                                    -- Bottom of the domain
                deriving( Eq, Show )
 
-instance LatticeLike PureResult where
-     bot = BotRes
-     top = TopRes
-     pre x y = (x == y) || (y == top)
-     lub x y | x == y = x 
-     lub _ _          = top
-     both x y | x == y = x 
-     both _ _          = bot
-
-
-------------------------------------------------------------------------
--- Constructed Product Result                                             
-------------------------------------------------------------------------
+lubCPR :: CPRResult -> CPRResult -> CPRResult
+lubCPR BotCPR      r           = r
+lubCPR RetProd     BotCPR      = RetProd
+lubCPR (RetSum t)  BotCPR      = RetSum t
+lubCPR (RetSum t1) (RetSum t2) 
+  | t1 == t2                   = RetSum t1
+lubCPR RetProd     RetProd     = RetProd
+lubCPR _ _                     = NoCPR
 
-data CPRResult = NoCPR
-               | RetCPR
-               deriving( Eq, Show )
+bothCPR :: CPRResult -> CPRResult -> CPRResult
+-- See Note [Asymmetry of 'both' for DmdType and DmdResult]
+bothCPR r _ = r
 
-instance LatticeLike CPRResult where
-     bot = RetCPR
-     top = NoCPR
-     pre x y = (x == y) || (y == top)
-     lub x y | x == y  = x 
-     lub _ _           = top
-     both x y | x == y = x 
-     both _ _          = bot
+instance Outputable DmdResult where
+  ppr RetProd    = char 'm' 
+  ppr (RetSum n) = char 'm' <> int n  
+  ppr BotCPR     = char 'b'   
+  ppr NoCPR      = empty   -- Keep these distinct from Demand letters
 
 ------------------------------------------------------------------------
 -- Combined demand result                                             --
 ------------------------------------------------------------------------
+type DmdResult = CPRResult
 
-data DmdResult = DR { res :: PureResult, cpr :: CPRResult }
-     deriving ( Eq )
-
--- TODO rework DmdResult to make it more clear
-instance LatticeLike DmdResult where
-  bot                        = botRes
-  top                        = topRes
+lubDmdResult :: DmdResult -> DmdResult -> DmdResult
+lubDmdResult = lubCPR
 
-  pre x _ | x == bot         = True
-  pre _ x | x == top         = True
-  pre (DR s1 a1) (DR s2 a2)  = (pre s1 s2) && (pre a1 a2)
-
-  lub  r r' | isBotRes r                   = r'
-  lub  r r' | isBotRes r'                  = r
-  lub  r r' 
-        | returnsCPR r && returnsCPR r'    = r
-  lub  _ _                                 = top
-
-  both _ r2 | isBotRes r2 = r2
-  both r1 _               = r1
-
--- Pretty-printing
-instance Outputable DmdResult where
-  ppr (DR {res=TopRes, cpr=RetCPR}) = char 'm'   --    DDDr without ambiguity
-  ppr (DR {res=BotRes}) = char 'b'   
-  ppr _ = empty   -- Keep these distinct from Demand letters
-
-mkDmdResult :: PureResult -> CPRResult -> DmdResult
-mkDmdResult BotRes RetCPR = botRes
-mkDmdResult x y = DR {res=x, cpr=y}
+bothDmdResult :: DmdResult -> DmdResult -> DmdResult
+bothDmdResult = bothCPR
 
 seqDmdResult :: DmdResult -> ()
-seqDmdResult (DR {res=x, cpr=y}) = x `seq` y `seq` ()
+seqDmdResult r = r `seq` ()
 
 -- [cprRes] lets us switch off CPR analysis
--- by making sure that everything uses TopRes instead of RetCPR
--- Assuming, of course, that they don't mention RetCPR by name.
--- They should onlyu use retCPR
-topRes, botRes, cprRes :: DmdResult
-topRes = mkDmdResult TopRes NoCPR
-botRes = mkDmdResult BotRes NoCPR
-cprRes | opt_CprOff = topRes
-       | otherwise  = mkDmdResult TopRes RetCPR
+-- by making sure that everything uses TopRes
+topRes, botRes :: DmdResult
+topRes = NoCPR
+botRes = BotCPR
+
+cprSumRes :: ConTag -> DmdResult
+cprSumRes tag | opt_CprOff = topRes
+              | otherwise  = RetSum tag
+cprProdRes :: DmdResult
+cprProdRes | opt_CprOff = topRes
+           | otherwise  = RetProd
+
 
 isTopRes :: DmdResult -> Bool
-isTopRes (DR {res=TopRes, cpr=NoCPR})  = True
-isTopRes _                  = False
+isTopRes NoCPR  = True
+isTopRes _      = False
 
 isBotRes :: DmdResult -> Bool
-isBotRes (DR {res=BotRes})      = True
-isBotRes _                  = False
+isBotRes BotCPR = True
+isBotRes _      = False
 
 returnsCPR :: DmdResult -> Bool
-returnsCPR (DR {res=TopRes, cpr=RetCPR}) = True
-returnsCPR _                  = False
+returnsCPR dr = isJust (returnsCPR_maybe dr)
+
+returnsCPRProd :: DmdResult -> Bool
+returnsCPRProd RetProd = True
+returnsCPRProd _       = False
+
+returnsCPR_maybe :: DmdResult -> Maybe ConTag
+returnsCPR_maybe (RetSum t) = Just t
+returnsCPR_maybe (RetProd)  = Just fIRST_TAG
+returnsCPR_maybe _          = Nothing
 
 resTypeArgDmd :: DmdResult -> Demand
 -- TopRes and BotRes are polymorphic, so that
 --      BotRes === Bot -> BotRes === ...
 --      TopRes === Top -> TopRes === ...
 -- This function makes that concrete
-resTypeArgDmd r | isBotRes r = bot
-resTypeArgDmd _              = top
+resTypeArgDmd r | isBotRes r = botDmd
+resTypeArgDmd _              = topDmd
 \end{code}
 
 %************************************************************************
@@ -647,10 +605,12 @@ worthSplittingFun ds res
         -- worthSplitting returns False for an empty list of demands,
         -- and hence do_strict_ww is False if arity is zero and there is no CPR
   where
+    worth_it (JD {absd=Abs})                  = True      -- Absent arg
+
     -- See Note [Worker-wrapper for bottoming functions]
-    worth_it (JD {strd=HyperStr, absd=a})     = isUsed a  -- A Hyper-strict argument, safe to do W/W
+    worth_it (JD {strd=HyperStr, absd=UProd _}) = True
+
     -- See Note [Worthy functions for Worker-Wrapper split]    
-    worth_it (JD {absd=Abs})                  = True      -- Absent arg
     worth_it (JD {strd=SProd _})              = True      -- Product arg to evaluate
     worth_it (JD {strd=Str, absd=UProd _})    = True      -- Strictly used product arg
     worth_it (JD {strd=Str, absd=UHead})      = True 
@@ -731,6 +691,19 @@ The re-boxing code won't go away unless error_fn gets a wrapper too.
 [We don't do reboxing now, but in general it's better to pass an
 unboxed thing to f, and have it reboxed in the error cases....]
 
+However we *don't* want to do this when the argument is not actually
+taken apart in the function at all.  Otherwise we risk decomposing a
+masssive tuple which is barely used.  Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+          
+Here, f does not take 'pr' apart, and it's stupid to do so.
+Imagine that it had millions of fields. This actually happened
+in GHC itself where the tuple was DynFlags
+
 
 %************************************************************************
 %*                                                                      *
@@ -781,7 +754,14 @@ Note [Asymmetry of 'both' for DmdType and DmdResult]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 'both' for DmdTypes is *assymetrical*, because there is only one
 result!  For example, given (e1 e2), we get a DmdType dt1 for e1, use
-its arg demand to analyse e2 giving dt2, and then do (dt1 `both` dt2).
+its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2).
+Similarly with 
+  case e of { p -> rhs }
+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then
+compute (dt_rhs `bothType` dt_scrut).
+
+We take the CPR info from FIRST argument, but combine both to get
+termination info.
 
 
 \begin{code}
@@ -791,25 +771,12 @@ instance Eq DmdType where
        (DmdType fv2 ds2 res2) =  ufmToList fv1 == ufmToList fv2
                               && ds1 == ds2 && res1 == res2
 
-instance LatticeLike DmdType where
-  bot  = botDmdType
-  top  = topDmdType
-  pre  = preDmdType
-  lub  = lubDmdType
-  both = bothDmdType
-
-preDmdType :: DmdType -> DmdType -> Bool
-preDmdType (DmdType _ ds1 res1) (DmdType _ ds2 res2)
-  =  (res1 `pre` res2)
-  && (length ds1 == length ds2)
-  && all (\(x, y) -> x `pre` y) (zip ds1 ds2)
-
 lubDmdType :: DmdType -> DmdType -> DmdType
 lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
-  = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lub` r2)
+  = DmdType lub_fv2 (lub_ds ds1 ds2) (r1 `lubDmdResult` r2)
   where
-    absLub  = lub absDmd
-    lub_fv  = plusVarEnv_C lub fv1 fv2
+    absLub  = lubDmd absDmd
+    lub_fv  = plusVarEnv_C lubDmd fv1 fv2
     -- Consider (if x then y else []) with demand V
     -- Then the first branch gives {y->V} and the second
     -- *implicitly* has {y->A}.  So we must put {y->(V `lub` A)}
@@ -819,10 +786,10 @@ lubDmdType (DmdType fv1 ds1 r1) (DmdType fv2 ds2 r2)
       -- lub is the identity for Bot
 
       -- Extend the shorter argument list to match the longer
-    lub_ds (d1:ds1) (d2:ds2) = lub d1 d2 : lub_ds ds1 ds2
+    lub_ds (d1:ds1) (d2:ds2) = lubDmd d1 d2 : lub_ds ds1 ds2
     lub_ds []     []       = []
-    lub_ds ds1    []       = map (`lub` resTypeArgDmd r2) ds1
-    lub_ds []     ds2      = map (resTypeArgDmd r1 `lub`) ds2
+    lub_ds ds1    []       = map (`lubDmd` resTypeArgDmd r2) ds1
+    lub_ds []     ds2      = map (resTypeArgDmd r1 `lubDmd`) ds2
  
 bothDmdType :: DmdType -> DmdType -> DmdType
 bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
@@ -831,11 +798,11 @@ bothDmdType (DmdType fv1 ds1 r1) (DmdType fv2 _ r2)
     -- using its second arg just for its free-var info.
     -- NB: Don't forget about r2!  It might be BotRes, which is
     -- a bottom demand on all the in-scope variables.
-  = DmdType both_fv2 ds1 (r1 `both` r2)
+  = DmdType both_fv2 ds1 (r1 `bothDmdResult` r2)
   where
-    both_fv  = plusVarEnv_C both fv1 fv2
-    both_fv1 = modifyEnv (isBotRes r1) (`both` bot) fv2 fv1 both_fv
-    both_fv2 = modifyEnv (isBotRes r2) (`both` bot) fv1 fv2 both_fv1
+    both_fv  = plusVarEnv_C bothDmd fv1 fv2
+    both_fv1 = modifyEnv (isBotRes r1) (`bothDmd` botDmd) fv2 fv1 both_fv
+    both_fv2 = modifyEnv (isBotRes r2) (`bothDmd` botDmd) fv1 fv2 both_fv1
 
 
 instance Outputable DmdType where
@@ -851,10 +818,12 @@ instance Outputable DmdType where
 emptyDmdEnv :: VarEnv Demand
 emptyDmdEnv = emptyVarEnv
 
-topDmdType, botDmdType, cprDmdType :: DmdType
+topDmdType, botDmdType :: DmdType
 topDmdType = DmdType emptyDmdEnv [] topRes
 botDmdType = DmdType emptyDmdEnv [] botRes
-cprDmdType = DmdType emptyDmdEnv [] cprRes
+
+cprProdDmdType :: DmdType
+cprProdDmdType = DmdType emptyDmdEnv [] cprProdRes
 
 isTopDmdType :: DmdType -> Bool
 isTopDmdType (DmdType env [] res)
@@ -882,7 +851,7 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)
 splitDmdTy ty@(DmdType _ [] res_ty)       = (resTypeArgDmd res_ty, ty)
 
 deferType :: DmdType -> DmdType
-deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] top
+deferType (DmdType fv _ _) = DmdType (deferEnv fv) [] topRes
 
 deferEnv :: DmdEnv -> DmdEnv
 deferEnv fv = mapVarEnv defer fv
@@ -956,7 +925,7 @@ splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
 increaseStrictSigArity :: Int -> StrictSig -> StrictSig
 -- Add extra arguments to a strictness signature
 increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res))
-  = StrictSig (DmdType env (replicate arity_increase top ++ dmds) res)
+  = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res)
 
 isTopSig :: StrictSig -> Bool
 isTopSig (StrictSig ty) = isTopDmdType ty
@@ -964,10 +933,12 @@ isTopSig (StrictSig ty) = isTopDmdType ty
 isBottomingSig :: StrictSig -> Bool
 isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res
 
-topSig, botSig, cprSig:: StrictSig
+topSig, botSig :: StrictSig
 topSig = StrictSig topDmdType
 botSig = StrictSig botDmdType
-cprSig = StrictSig cprDmdType
+
+cprProdSig :: StrictSig
+cprProdSig = StrictSig cprProdDmdType
 
 dmdTransformSig :: StrictSig -> Demand -> DmdType
 -- (dmdTransformSig fun_sig dmd) considers a call to a function whose
@@ -977,8 +948,8 @@ dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) dmd
   = go arg_ds dmd
   where
     go [] dmd 
-      | isBotDmd dmd = bot     -- Transform bottom demand to bottom type
-      | otherwise    = dmd_ty  -- Saturated
+      | isBotDmd dmd = botDmdType -- Transform bottom demand to bottom type
+      | otherwise    = dmd_ty     -- Saturated
     go (_:as) dmd    = case peelCallDmd dmd of
                         Just dmd' -> go as dmd'
                         Nothing   -> deferType dmd_ty
@@ -1089,16 +1060,6 @@ instance Binary JointDmd where
               y <- get bh
               return $ mkJointDmd x y
 
-instance Binary PureResult where
-    put_ bh BotRes       = do putByte bh 0
-    put_ bh TopRes       = do putByte bh 1
-
-    get  bh = do
-            h <- getByte bh
-            case h of 
-              0 -> return bot       
-              _ -> return top
-
 instance Binary StrictSig where
     put_ bh (StrictSig aa) = do
             put_ bh aa
@@ -1117,19 +1078,16 @@ instance Binary DmdType where
            return (DmdType emptyDmdEnv ds dr)
 
 instance Binary CPRResult where
-    put_ bh RetCPR       = do putByte bh 0
-    put_ bh NoCPR        = do putByte bh 1
+    put_ bh (RetSum n)   = do { putByte bh 0; put_ bh n }
+    put_ bh RetProd      = putByte bh 1
+    put_ bh NoCPR        = putByte bh 2
+    put_ bh BotCPR       = putByte bh 3
 
     get  bh = do
             h <- getByte bh
             case h of 
-              0 -> return bot       
-              _ -> return top
-
-instance Binary DmdResult where
-    put_ bh (DR {res=x, cpr=y}) = do put_ bh x; put_ bh y
-    get  bh = do 
-              x <- get bh
-              y <- get bh
-              return $ mkDmdResult x y
-\end{code}
\ No newline at end of file
+              0 -> do { n <- get bh; return (RetSum n) }
+              1 -> return RetProd
+              2 -> return NoCPR
+              _ -> return BotCPR
+\end{code}
index 0107e41..f0248fc 100644 (file)
@@ -129,7 +129,7 @@ data IdDetails
                                --  b) when desugaring a RecordCon we can get 
                                --     from the Id back to the data con]
 
-  | ClassOpId Class            -- ^ The 'Id' is an superclass selector or class operation of a class
+  | ClassOpId Class            -- ^ The 'Id' is a superclass selector or class operation of a class
 
   | PrimOpId PrimOp            -- ^ The 'Id' is for a primitive operator
   | FCallId ForeignCall                -- ^ The 'Id' is for a foreign call
index 3fdf86d..112664c 100644 (file)
@@ -291,7 +291,7 @@ mkDictSelId dflags no_unf name clas
                                        else mkImplicitUnfolding dflags rhs)
                   -- In module where class op is defined, we must add
                   -- the unfolding, even though it'll never be inlined
-                  -- becuase we use that to generate a top-level binding
+                  -- because we use that to generate a top-level binding
                   -- for the ClassOp
 
     info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma
@@ -425,16 +425,17 @@ mkDataConWorkId wkr_name data_con
 
 dataConCPR :: DataCon -> DmdResult
 dataConCPR con
-  | isProductTyCon tycon
-  , isDataTyCon tycon
+  | isDataTyCon tycon     -- Real data types only; that is, 
+                          -- not unboxed tuples or newtypes
+  , isVanillaDataCon con  -- No existentials 
   , wkr_arity > 0
   , wkr_arity <= mAX_CPR_SIZE
-  = cprRes
+  = if is_prod then cprProdRes 
+               else cprSumRes (dataConTag con)
   | otherwise
   = topRes
-        -- RetCPR is only true for products that are real data types;
-        -- that is, not unboxed tuples or [non-recursive] newtypes
   where
+    is_prod = isProductTyCon tycon
     tycon = dataConTyCon con
     wkr_arity = dataConRepArity con
 
index 2c008f5..cfd846a 100644 (file)
@@ -257,7 +257,7 @@ data RealSrcSpan
           srcSpanLine     :: {-# UNPACK #-} !Int,
           srcSpanCol      :: {-# UNPACK #-} !Int
         }
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
                                 -- derive Show for Token
 
 data SrcSpan =
@@ -265,7 +265,7 @@ data SrcSpan =
   | UnhelpfulSpan !FastString   -- Just a general indication
                                 -- also used to indicate an empty span
 
-  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
+  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, because we
                                 -- derive Show for Token
 
 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
index 6d078d4..16eb886 100644 (file)
@@ -352,7 +352,7 @@ idDetails (Id { id_details = details }) = details
 idDetails other                        = pprPanic "idDetails" (ppr other)
 
 -- The next three have a 'Var' suffix even though they always build
--- Ids, becuase Id.lhs uses 'mkGlobalId' etc with different types
+-- Ids, because Id.lhs uses 'mkGlobalId' etc with different types
 mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
 mkGlobalVar details name ty info
   = mk_id name ty GlobalId details info
index 259f31a..ebc9e53 100644 (file)
@@ -107,7 +107,6 @@ module CLabel (
 import IdInfo
 import BasicTypes
 import Packages
-import DataCon
 import Module
 import Name
 import Unique
index 7007872..913f15d 100644 (file)
@@ -67,8 +67,13 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
       assignments = reg_assts ++ stk_assts
 
       assign_regs assts []     _    = (assts, [])
-      assign_regs assts (r:rs) regs = if isFloatType ty then float else int
-        where float = case (w, regs) of
+      assign_regs assts (r:rs) regs | isVecType ty   = vec
+                                    | isFloatType ty = float
+                                    | otherwise      = int
+        where vec = case (w, regs) of
+                      (W128, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
+                      _ -> (assts, (r:rs))
+              float = case (w, regs) of
                         (W32, (vs, fs, ds, ls, s:ss)) -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
                         (W32, (vs, f:fs, ds, ls, ss))
                             | not hasSseRegs          -> k (RegisterParam f, (vs, fs, ds, ls, ss))
index 614edf2..522d323 100644 (file)
@@ -119,6 +119,7 @@ hash_block block =
         hash_lit :: CmmLit -> Word32
         hash_lit (CmmInt i _) = fromInteger i
         hash_lit (CmmFloat r _) = truncate r
+        hash_lit (CmmVec ls) = hash_list hash_lit ls
         hash_lit (CmmLabel _) = 119 -- ugh
         hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
         hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
index 87713c6..1df8e84 100644 (file)
@@ -33,6 +33,7 @@ import BlockId
 import CLabel
 import DynFlags
 import Unique
+import Outputable (panic)
 
 import Data.Set (Set)
 import qualified Data.Set as Set
@@ -101,6 +102,7 @@ data CmmLit
         -- it will be used as a signed or unsigned value (the CmmType doesn't
         -- distinguish between signed & unsigned).
   | CmmFloat  Rational Width
+  | CmmVec [CmmLit]                     -- Vector literal
   | CmmLabel    CLabel                  -- Address of label
   | CmmLabelOff CLabel Int              -- Address of label + byte offset
 
@@ -133,6 +135,11 @@ cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address
 cmmLitType :: DynFlags -> CmmLit -> CmmType
 cmmLitType _      (CmmInt _ width)     = cmmBits  width
 cmmLitType _      (CmmFloat _ width)   = cmmFloat width
+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"
+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l
+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
+                                            then cmmVec (1+length ls) ty
+                                            else panic "cmmLitType: CmmVec"
 cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl
 cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl
 cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
@@ -329,6 +336,9 @@ data GlobalReg
   | LongReg             -- long int registers (64-bit, really)
         {-# UNPACK #-} !Int     -- its number
 
+  | XmmReg                      -- 128-bit SIMD vector register 
+        {-# UNPACK #-} !Int     -- its number
+
   -- STG registers
   | Sp                  -- Stack ptr; points to last occupied stack location.
   | SpLim               -- Stack limit
@@ -364,6 +374,7 @@ instance Eq GlobalReg where
    FloatReg i == FloatReg j = i==j
    DoubleReg i == DoubleReg j = i==j
    LongReg i == LongReg j = i==j
+   XmmReg i == XmmReg j = i==j
    Sp == Sp = True
    SpLim == SpLim = True
    Hp == Hp = True
@@ -385,6 +396,7 @@ instance Ord GlobalReg where
    compare (FloatReg i)  (FloatReg  j) = compare i j
    compare (DoubleReg i) (DoubleReg j) = compare i j
    compare (LongReg i)   (LongReg   j) = compare i j
+   compare (XmmReg i)    (XmmReg    j) = compare i j
    compare Sp Sp = EQ
    compare SpLim SpLim = EQ
    compare Hp Hp = EQ
@@ -406,6 +418,8 @@ instance Ord GlobalReg where
    compare _ (DoubleReg _)    = GT
    compare (LongReg _) _      = LT
    compare _ (LongReg _)      = GT
+   compare (XmmReg _) _       = LT
+   compare _ (XmmReg _)       = GT
    compare Sp _ = LT
    compare _ Sp = GT
    compare SpLim _ = LT
@@ -448,6 +462,8 @@ globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
 globalRegType _      (FloatReg _)      = cmmFloat W32
 globalRegType _      (DoubleReg _)     = cmmFloat W64
 globalRegType _      (LongReg _)       = cmmBits W64
+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)
+
 globalRegType dflags Hp                = gcWord dflags
                                             -- The initialiser for all
                                             -- dynamically allocated closures
@@ -458,4 +474,5 @@ isArgReg (VanillaReg {}) = True
 isArgReg (FloatReg {})   = True
 isArgReg (DoubleReg {})  = True
 isArgReg (LongReg {})    = True
+isArgReg (XmmReg {})     = True
 isArgReg _               = False
index 718eb27..81227eb 100644 (file)
@@ -163,6 +163,7 @@ data CmmToken
   | CmmT_bits16
   | CmmT_bits32
   | CmmT_bits64
+  | CmmT_bits128
   | CmmT_float32
   | CmmT_float64
   | CmmT_gcptr
@@ -242,6 +243,7 @@ reservedWordsFM = listToUFM $
        ( "bits16",             CmmT_bits16 ),
        ( "bits32",             CmmT_bits32 ),
        ( "bits64",             CmmT_bits64 ),
+       ( "bits128",            CmmT_bits128 ),
        ( "float32",            CmmT_float32 ),
        ( "float64",            CmmT_float64 ),
 -- New forms
@@ -249,6 +251,7 @@ reservedWordsFM = listToUFM $
        ( "b16",                CmmT_bits16 ),
        ( "b32",                CmmT_bits32 ),
        ( "b64",                CmmT_bits64 ),
+       ( "b128",               CmmT_bits128 ),
        ( "f32",                CmmT_float32 ),
        ( "f64",                CmmT_float64 ),
        ( "gcptr",              CmmT_gcptr )
index a6c9bee..fae84e5 100644 (file)
@@ -103,6 +103,31 @@ data MachOp
   | MO_SS_Conv Width Width      -- Signed int -> Signed int
   | MO_UU_Conv Width Width      -- unsigned int -> unsigned int
   | MO_FF_Conv Width Width      -- Float -> Float
+
+  -- Vector element insertion and extraction operations
+  | MO_V_Insert  Length Width   -- Insert scalar into vector
+  | MO_V_Extract Length Width   -- Extract scalar from vector
+  
+  -- Integer vector operations
+  | MO_V_Add Length Width  
+  | MO_V_Sub Length Width  
+  | MO_V_Mul Length Width
+
+  -- Signed vector multiply/divide
+  | MO_VS_Quot Length Width
+  | MO_VS_Rem  Length Width
+  | MO_VS_Neg  Length Width
+
+  -- Floting point vector element insertion and extraction operations
+  | MO_VF_Insert  Length Width   -- Insert scalar into vector
+  | MO_VF_Extract Length Width   -- Extract scalar from vector
+
+  -- Floating point vector operations
+  | MO_VF_Add  Length Width  
+  | MO_VF_Sub  Length Width  
+  | MO_VF_Neg  Length Width             -- unary -
+  | MO_VF_Mul  Length Width
+  | MO_VF_Quot Length Width
   deriving (Eq, Show)
 
 pprMachOp :: MachOp -> SDoc
@@ -338,6 +363,26 @@ machOpResultType dflags mop tys =
     MO_FS_Conv _ to     -> cmmBits to
     MO_SF_Conv _ to     -> cmmFloat to
     MO_FF_Conv _ to     -> cmmFloat to
+
+    MO_V_Insert  l w    -> cmmVec l (cmmBits w)
+    MO_V_Extract _ w    -> cmmBits w
+
+    MO_V_Add l w        -> cmmVec l (cmmBits w)
+    MO_V_Sub l w        -> cmmVec l (cmmBits w)
+    MO_V_Mul l w        -> cmmVec l (cmmBits w)
+
+    MO_VS_Quot l w      -> cmmVec l (cmmBits w)
+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)
+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)
+
+    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)
+    MO_VF_Extract _ w   -> cmmFloat w
+
+    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)
   where
     (ty1:_) = tys
 
@@ -405,6 +450,26 @@ machOpArgReps dflags op =
     MO_FS_Conv from _   -> [from]
     MO_FF_Conv from _   -> [from]
 
+    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]
+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]
+
+    MO_V_Add _ r        -> [r,r]
+    MO_V_Sub _ r        -> [r,r]
+    MO_V_Mul _ r        -> [r,r]
+
+    MO_VS_Quot _ r      -> [r,r]
+    MO_VS_Rem  _ r      -> [r,r]
+    MO_VS_Neg  _ r      -> [r]
+
+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
+
+    MO_VF_Add  _ r      -> [r,r]
+    MO_VF_Sub  _ r      -> [r,r]
+    MO_VF_Mul  _ r      -> [r,r]
+    MO_VF_Quot _ r      -> [r,r]
+    MO_VF_Neg  _ r      -> [r]
+
 -----------------------------------------------------------------------------
 -- CallishMachOp
 -----------------------------------------------------------------------------
@@ -452,6 +517,10 @@ data CallishMachOp
   | MO_WriteBarrier
   | MO_Touch         -- Keep variables live (when using interior pointers)
 
+  -- Prefetch
+  | MO_Prefetch_Data -- Prefetch hint. May change program performance but not
+                     -- program behavior.
+
   -- Note that these three MachOps all take 1 extra parameter than the
   -- standard C lib versions. The extra (last) parameter contains
   -- alignment of the pointers. Used for optimisation in backends.
index edeeebb..cb3bf0c 100644 (file)
@@ -288,6 +288,7 @@ import Data.Maybe
         'bits16'        { L _ (CmmT_bits16) }
         'bits32'        { L _ (CmmT_bits32) }
         'bits64'        { L _ (CmmT_bits64) }
+        'bits128'       { L _ (CmmT_bits128) }
         'float32'       { L _ (CmmT_float32) }
         'float64'       { L _ (CmmT_float64) }
         'gcptr'         { L _ (CmmT_gcptr) }
@@ -772,6 +773,7 @@ typenot8 :: { CmmType }
         : 'bits16'              { b16 }
         | 'bits32'              { b32 }
         | 'bits64'              { b64 }
+        | 'bits128'             { b128 }
         | 'float32'             { f32 }
         | 'float64'             { f64 }
         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
index 9a443c1..49a2dc1 100644 (file)
@@ -1,7 +1,7 @@
 
 module CmmType
     ( CmmType   -- Abstract
-    , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
+    , b8, b16, b32, b64, b128, f32, f64, bWord, bHalfWord, gcWord
     , cInt, cLong
     , cmmBits, cmmFloat
     , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
@@ -17,6 +17,13 @@ module CmmType
     , rEP_StgEntCounter_allocs
 
     , ForeignHint(..)
+
+    , Length
+    , vec, vec2, vec4, vec8, vec16
+    , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8
+    , cmmVec
+    , vecLength, vecElemType
+    , isVecType
    )
 where
 
@@ -42,10 +49,11 @@ import Data.Int
 data CmmType    -- The important one!
   = CmmType CmmCat Width
 
-data CmmCat     -- "Category" (not exported)
-   = GcPtrCat   -- GC pointer
-   | BitsCat    -- Non-pointer
-   | FloatCat   -- Float
+data CmmCat                -- "Category" (not exported)
+   = GcPtrCat              -- GC pointer
+   | BitsCat               -- Non-pointer
+   | FloatCat              -- Float
+   | VecCat Length CmmCat  -- Vector
    deriving( Eq )
         -- See Note [Signed vs unsigned] at the end
 
@@ -53,9 +61,10 @@ instance Outputable CmmType where
   ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
 
 instance Outputable CmmCat where
-  ppr FloatCat  = ptext $ sLit("F")
-  ppr GcPtrCat  = ptext $ sLit("P")
-  ppr BitsCat   = ptext $ sLit("I")
+  ppr FloatCat       = ptext $ sLit("F")
+  ppr GcPtrCat       = ptext $ sLit("P")
+  ppr BitsCat        = ptext $ sLit("I")
+  ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V"
 
 -- Why is CmmType stratified?  For native code generation,
 -- most of the time you just want to know what sort of register
@@ -77,10 +86,15 @@ cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool
 cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)
    = c1 `weak_eq` c2 && w1==w2
    where
-      FloatCat `weak_eq` FloatCat = True
-      FloatCat `weak_eq` _other   = False
-      _other   `weak_eq` FloatCat = False
-      _word1   `weak_eq` _word2   = True        -- Ignores GcPtr
+     weak_eq :: CmmCat -> CmmCat -> Bool
+     FloatCat         `weak_eq` FloatCat         = True
+     FloatCat         `weak_eq` _other           = False
+     _other           `weak_eq` FloatCat         = False
+     (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2
+                                                   && cat1 `weak_eq` cat2
+     (VecCat {})      `weak_eq` _other           = False
+     _other           `weak_eq` (VecCat {})      = False
+     _word1           `weak_eq` _word2           = True        -- Ignores GcPtr
 
 --- Simple operations on CmmType -----
 typeWidth :: CmmType -> Width
@@ -92,11 +106,12 @@ cmmFloat = CmmType FloatCat
 
 -------- Common CmmTypes ------------
 -- Floats and words of specific widths
-b8, b16, b32, b64, f32, f64 :: CmmType
+b8, b16, b32, b64, b128, f32, f64 :: CmmType
 b8     = cmmBits W8
 b16    = cmmBits W16
 b32    = cmmBits W32
 b64    = cmmBits W64
+b128   = cmmBits W128
 f32    = cmmFloat W32
 f64    = cmmFloat W64
 
@@ -244,6 +259,51 @@ narrowS W32 x = fromIntegral (fromIntegral x :: Int32)
 narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
 narrowS _ _ = panic "narrowTo"
 
+-----------------------------------------------------------------------------
+--              SIMD
+-----------------------------------------------------------------------------
+
+type Length = Int
+
+vec :: Length -> CmmType -> CmmType
+vec l (CmmType cat w) = CmmType (VecCat l cat) vecw
+  where
+    vecw :: Width
+    vecw = widthFromBytes (l*widthInBytes w)
+
+vec2, vec4, vec8, vec16 :: CmmType -> CmmType
+vec2  = vec 2
+vec4  = vec 4
+vec8  = vec 8
+vec16 = vec 16
+
+vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType
+vec2f64 = vec 2 f64
+vec2b64 = vec 2 b64
+vec4f32 = vec 4 f32
+vec4b32 = vec 4 b32
+vec8b16 = vec 8 b16
+vec16b8 = vec 16 b8
+
+cmmVec :: Int -> CmmType -> CmmType
+cmmVec n (CmmType cat w) =
+    CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w))
+
+vecLength :: CmmType -> Length
+vecLength (CmmType (VecCat l _) _) = l
+vecLength _                        = panic "vecLength: not a vector"
+
+vecElemType :: CmmType -> CmmType
+vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw
+  where
+    scalw :: Width
+    scalw = widthFromBytes (widthInBytes w `div` l)
+vecElemType _ = panic "vecElemType: not a vector"
+
+isVecType :: CmmType -> Bool
+isVecType (CmmType (VecCat {}) _) = True
+isVecType _                       = False
+
 -------------------------------------------------------------------------
 -- Hints
 
index c822da9..5530b77 100644 (file)
@@ -52,7 +52,8 @@ module CmmUtils(
         modifyGraph,
 
         ofBlockMap, toBlockMap, insertBlock,
-        ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst,
+        ofBlockList, toBlockList, bodyToBlockList,
+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
         foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
 
         analFwd, analBwd, analRewFwd, analRewBwd,
@@ -62,7 +63,7 @@ module CmmUtils(
 
 #include "HsVersions.h"
 
-import TyCon    ( PrimRep(..) )
+import TyCon    ( PrimRep(..), PrimElemRep(..) )
 import Type     ( UnaryType, typePrimRep )
 
 import SMRep
@@ -87,15 +88,28 @@ import Hoopl
 ---------------------------------------------------
 
 primRepCmmType :: DynFlags -> PrimRep -> CmmType
-primRepCmmType _      VoidRep    = panic "primRepCmmType:VoidRep"
-primRepCmmType dflags PtrRep     = gcWord dflags
-primRepCmmType dflags IntRep     = bWord dflags
-primRepCmmType dflags WordRep    = bWord dflags
-primRepCmmType _      Int64Rep   = b64
-primRepCmmType _      Word64Rep  = b64
-primRepCmmType dflags AddrRep    = bWord dflags
-primRepCmmType _      FloatRep   = f32
-primRepCmmType _      DoubleRep  = f64
+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
+primRepCmmType dflags PtrRep           = gcWord dflags
+primRepCmmType dflags IntRep           = bWord dflags
+primRepCmmType dflags WordRep          = bWord dflags
+primRepCmmType _      Int64Rep         = b64
+primRepCmmType _      Word64Rep        = b64
+primRepCmmType dflags AddrRep          = bWord dflags
+primRepCmmType _      FloatRep         = f32
+primRepCmmType _      DoubleRep        = f64
+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)
+
+primElemRepCmmType :: PrimElemRep -> CmmType
+primElemRepCmmType Int8ElemRep   = b8
+primElemRepCmmType Int16ElemRep  = b16
+primElemRepCmmType Int32ElemRep  = b32
+primElemRepCmmType Int64ElemRep  = b64
+primElemRepCmmType Word8ElemRep  = b8
+primElemRepCmmType Word16ElemRep = b16
+primElemRepCmmType Word32ElemRep = b32
+primElemRepCmmType Word64ElemRep = b64
+primElemRepCmmType FloatElemRep  = f32
+primElemRepCmmType DoubleElemRep = f64
 
 typeCmmType :: DynFlags -> UnaryType -> CmmType
 typeCmmType dflags ty = primRepCmmType dflags (typePrimRep ty)
@@ -110,6 +124,7 @@ primRepForeignHint Word64Rep    = NoHint
 primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
 primRepForeignHint FloatRep     = NoHint
 primRepForeignHint DoubleRep    = NoHint
+primRepForeignHint (VecRep {})  = NoHint
 
 typeForeignHint :: UnaryType -> ForeignHint
 typeForeignHint = primRepForeignHint . typePrimRep
@@ -434,6 +449,34 @@ toBlockListEntryFirst g
     Just entry_block = mapLookup entry_id m
     others = filter ((/= entry_id) . entryLabel) (mapElems m)
 
+-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
+-- so that the false case of a conditional jumps to the next block in the output
+-- list of blocks. This matches the way OldCmm blocks were output since in
+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
+-- have both true and false successors. Block ordering can make a big difference
+-- in performance in the LLVM backend. Note that we rely crucially on the order
+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
+-- defind in cmm/CmmNode.hs. -GBM
+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirstFalseFallthrough g
+  | mapNull m  = []
+  | otherwise  = dfs setEmpty [entry_block]
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+
+    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
+    dfs _ [] = []
+    dfs visited (block:bs)
+      | id `setMember` visited = dfs visited bs
+      | otherwise              = block : dfs (setInsert id visited) bs'
+      where id = entryLabel block
+            bs' = foldr add_id bs (successors block)
+            add_id id bs = case mapLookup id m of
+                              Just b  -> b : bs
+                              Nothing -> bs
+
 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
 ofBlockList entry blocks = CmmGraph { g_entry = entry
                                     , g_graph = GMany NothingO body NothingO }
index 45f46b8..45c415f 100644 (file)
@@ -467,6 +467,8 @@ pprLit lit = case lit of
                 -- these constants come from <math.h>
                 -- see #1861
 
+    CmmVec {} -> panic "PprC printing vector literal"
+
     CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
     CmmHighStackMark   -> panic "PprC printing high stack mark"
     CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
@@ -624,6 +626,71 @@ pprMachOp_for_C mop = case mop of
                                 (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
                                       ++ " should have been handled earlier!")
 
+        MO_V_Insert {}    -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_V_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_V_Extract {}   -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_V_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_V_Add {}       -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_V_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
+                                      ++ " should have been handled earlier!")
+        MO_V_Sub {}       -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_V_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_V_Mul {}       -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_V_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
+                                      ++ " should have been handled earlier!")
+
+        MO_VS_Quot {}     -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VS_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Rem {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VS_Rem")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Neg {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VS_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Insert {}   -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Extract {}  -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Add {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Sub {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Neg {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Mul {}      -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Quot {}     -> pprTrace "offending mop:"
+                                (ptext $ sLit "MO_VF_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
+                                      ++ " should have been handled earlier!")
+
 signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
 signedOp (MO_S_Quot _)    = True
 signedOp (MO_S_Rem  _)    = True
@@ -692,6 +759,7 @@ pprCallishMachOp_for_C mop
         MO_Add2       {} -> unsupported
         MO_U_Mul2     {} -> unsupported
         MO_Touch         -> unsupported
+        MO_Prefetch_Data -> unsupported
     where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
                             ++ " not supported!")
 
index 71c8446..d1128b0 100644 (file)
@@ -194,6 +194,7 @@ pprLit lit = sdocWithDynFlags $ \dflags ->
                space <> dcolon <+> ppr rep ]
 
     CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]
+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'
     CmmLabel clbl      -> ppr clbl
     CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
     CmmLabelDiffOff clbl1 clbl2 i -> ppr clbl1 <> char '-'
@@ -254,6 +255,7 @@ pprGlobalReg gr
         FloatReg   n   -> char 'F' <> int n
         DoubleReg  n   -> char 'D' <> int n
         LongReg    n   -> char 'L' <> int n
+        XmmReg     n   -> ptext (sLit "XMM") <> int n
         Sp             -> ptext (sLit "Sp")
         SpLim          -> ptext (sLit "SpLim")
         Hp             -> ptext (sLit "Hp")
index bdb7f69..c06dd60 100644 (file)
@@ -49,6 +49,13 @@ baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags
 baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags
 baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags
 baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags
+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags
+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags
+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags
+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags
+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags
+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
 baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags
 baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags
 baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags
index ddc6d91..3e95c59 100644 (file)
@@ -129,7 +129,7 @@ buildDynCon' :: DynFlags
 
 {- We used to pass a boolean indicating whether all the
 args were of size zero, so we could use a static
-construtor; but I concluded that it just isn't worth it.
+constructor; but I concluded that it just isn't worth it.
 Now I/O uses unboxed tuples there just aren't any constructors
 with all size-zero args.
 
index 8544709..a3bbefe 100644 (file)
@@ -46,7 +46,7 @@ import CLabel
 import StgSyn
 import Id
 import Name
-import TyCon           ( PrimRep(..) )
+import TyCon           ( PrimRep(..), primElemRepSizeB )
 import BasicTypes      ( RepArity )
 import DynFlags
 import Module
@@ -317,6 +317,7 @@ slowCallPattern (N: _)                    = (fsLit "stg_ap_n", 1)
 slowCallPattern (F: _)               = (fsLit "stg_ap_f", 1)
 slowCallPattern (D: _)               = (fsLit "stg_ap_d", 1)
 slowCallPattern (L: _)               = (fsLit "stg_ap_l", 1)
+slowCallPattern (V16: _)             = (fsLit "stg_ap_v16", 1)
 slowCallPattern []                   = (fsLit "stg_ap_0", 0)
 
 
@@ -333,36 +334,42 @@ data ArgRep = P   -- GC Ptr
             | V   -- Void
             | F   -- Float
             | D   -- Double
+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.
 instance Outputable ArgRep where
-  ppr P = text "P"
-  ppr N = text "N"
-  ppr L = text "L"
-  ppr V = text "V"
-  ppr F = text "F"
-  ppr D = text "D"
+  ppr P   = text "P"
+  ppr N   = text "N"
+  ppr L   = text "L"
+  ppr V   = text "V"
+  ppr F   = text "F"
+  ppr D   = text "D"
+  ppr V16 = text "V16"
 
 toArgRep :: PrimRep -> ArgRep
-toArgRep VoidRep   = V
-toArgRep PtrRep    = P
-toArgRep IntRep    = N
-toArgRep WordRep   = N
-toArgRep AddrRep   = N
-toArgRep Int64Rep  = L
-toArgRep Word64Rep = L
-toArgRep FloatRep  = F
-toArgRep DoubleRep = D
+toArgRep VoidRep           = V
+toArgRep PtrRep            = P
+toArgRep IntRep            = N
+toArgRep WordRep           = N
+toArgRep AddrRep           = N
+toArgRep Int64Rep          = L
+toArgRep Word64Rep         = L
+toArgRep FloatRep          = F
+toArgRep DoubleRep         = D
+toArgRep (VecRep len elem)
+    | len*primElemRepSizeB elem == 16 = V16
+    | otherwise                       = error "toArgRep: bad vector primrep"
 
 isNonV :: ArgRep -> Bool
 isNonV V = False
 isNonV _ = True
 
 argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words
-argRepSizeW _      N = 1
-argRepSizeW _      P = 1
-argRepSizeW _      F = 1
-argRepSizeW dflags L = wORD64_SIZE        `quot` wORD_SIZE dflags
-argRepSizeW dflags D = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
-argRepSizeW _      V = 0
+argRepSizeW _      N   = 1
+argRepSizeW _      P   = 1
+argRepSizeW _      F   = 1
+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags
+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
+argRepSizeW _      V   = 0
+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags
 
 idArgRep :: Id -> ArgRep
 idArgRep = toArgRep . idPrimRep
@@ -456,12 +463,13 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
 stdPattern :: [ArgRep] -> Maybe Int
 stdPattern reps
   = case reps of
-       []  -> Just ARG_NONE    -- just void args, probably
-       [N] -> Just ARG_N
-       [P] -> Just ARG_P
-       [F] -> Just ARG_F
-       [D] -> Just ARG_D
-       [L] -> Just ARG_L
+       []    -> Just ARG_NONE  -- just void args, probably
+       [N]   -> Just ARG_N
+       [P]   -> Just ARG_P
+       [F]   -> Just ARG_F
+       [D]   -> Just ARG_D
+       [L]   -> Just ARG_L
+       [V16] -> Just ARG_V16
 
        [N,N] -> Just ARG_NN
        [N,P] -> Just ARG_NP
index 9862866..4005f6d 100644 (file)
@@ -265,6 +265,15 @@ emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]
 emitPrimOp _ res@[] TouchOp args@[_arg]
    = do emitPrimCall res MO_Touch args
 
+emitPrimOp _ res@[] PrefetchByteArrayOp args@[_arg]
+   = do emitPrimCall res MO_Prefetch_Data args
+
+emitPrimOp _ res@[] PrefetchMutableByteArrayOp args@[_arg]
+   = do emitPrimCall res MO_Prefetch_Data args
+
+emitPrimOp _ res@[] PrefetchAddrOp args@[_arg]
+   = do emitPrimCall res MO_Prefetch_Data args
+
 --  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
 emitPrimOp dflags [res] ByteArrayContents_Char [arg]
    = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
@@ -365,117 +374,165 @@ emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
 
 -- IndexXXXoffAddr
 
-emitPrimOp dflags res IndexOffAddrOp_Char      args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res IndexOffAddrOp_WideChar  args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res IndexOffAddrOp_Int       args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Word      args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Addr      args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _      res IndexOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
-emitPrimOp _      res IndexOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
-emitPrimOp dflags res IndexOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexOffAddrOp_Int8      args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexOffAddrOp_Int16     args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
-emitPrimOp dflags res IndexOffAddrOp_Int32     args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
-emitPrimOp _      res IndexOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp dflags res IndexOffAddrOp_Word8     args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexOffAddrOp_Word16    args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
-emitPrimOp dflags res IndexOffAddrOp_Word32    args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp _      res IndexOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
+emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp _      res IndexOffAddrOp_FloatX4          args = doIndexOffAddrOp   Nothing vec4f32 res args
+emitPrimOp _      res IndexOffAddrOp_FloatAsFloatX4   args = doIndexOffAddrOpAs Nothing vec4f32 f32 res args
+emitPrimOp _      res IndexOffAddrOp_DoubleX2         args = doIndexOffAddrOp   Nothing vec2f64 res args
+emitPrimOp _      res IndexOffAddrOp_DoubleAsDoubleX2 args = doIndexOffAddrOpAs Nothing vec2f64 f64 res args
+emitPrimOp _      res IndexOffAddrOp_Int32X4          args = doIndexOffAddrOp   Nothing vec4b32 res args
+emitPrimOp _      res IndexOffAddrOp_Int32AsInt32X4   args = doIndexOffAddrOpAs Nothing vec4b32 b32 res args
+emitPrimOp _      res IndexOffAddrOp_Int64X2          args = doIndexOffAddrOp   Nothing vec2b64 res args
+emitPrimOp _      res IndexOffAddrOp_Int64AsInt64X2   args = doIndexOffAddrOpAs Nothing vec2b64 b64 res args
 
 -- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
 
-emitPrimOp dflags res ReadOffAddrOp_Char      args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res ReadOffAddrOp_WideChar  args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res ReadOffAddrOp_Int       args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Word      args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Addr      args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp _      res ReadOffAddrOp_Float     args = doIndexOffAddrOp Nothing f32 res args
-emitPrimOp _      res ReadOffAddrOp_Double    args = doIndexOffAddrOp Nothing f64 res args
-emitPrimOp dflags res ReadOffAddrOp_StablePtr args = doIndexOffAddrOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadOffAddrOp_Int8      args = doIndexOffAddrOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadOffAddrOp_Int16     args = doIndexOffAddrOp (Just (mo_s_16ToWord dflags)) b16 res args
-emitPrimOp dflags res ReadOffAddrOp_Int32     args = doIndexOffAddrOp (Just (mo_s_32ToWord dflags)) b32 res args
-emitPrimOp _      res ReadOffAddrOp_Int64     args = doIndexOffAddrOp Nothing b64 res args
-emitPrimOp dflags res ReadOffAddrOp_Word8     args = doIndexOffAddrOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadOffAddrOp_Word16    args = doIndexOffAddrOp (Just (mo_u_16ToWord dflags)) b16 res args
-emitPrimOp dflags res ReadOffAddrOp_Word32    args = doIndexOffAddrOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp _      res ReadOffAddrOp_Word64    args = doIndexOffAddrOp Nothing b64 res args
+emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp _      res ReadOffAddrOp_FloatX4          args = doIndexOffAddrOp   Nothing vec4f32 res args
+emitPrimOp _      res ReadOffAddrOp_FloatAsFloatX4   args = doIndexOffAddrOpAs Nothing vec4f32 b32 res args
+emitPrimOp _      res ReadOffAddrOp_DoubleX2         args = doIndexOffAddrOp   Nothing vec2f64 res args
+emitPrimOp _      res ReadOffAddrOp_DoubleAsDoubleX2 args = doIndexOffAddrOpAs Nothing vec2f64 b64 res args
+emitPrimOp _      res ReadOffAddrOp_Int32X4          args = doIndexOffAddrOp   Nothing vec4b32 res args
+emitPrimOp _      res ReadOffAddrOp_Int32AsInt32X4   args = doIndexOffAddrOpAs Nothing vec4b32 b32 res args
+emitPrimOp _      res ReadOffAddrOp_Int64X2          args = doIndexOffAddrOp   Nothing vec2b64 res args
+emitPrimOp _      res ReadOffAddrOp_Int64AsInt64X2   args = doIndexOffAddrOpAs Nothing vec2b64 b64 res args
 
 -- IndexXXXArray
 
-emitPrimOp dflags res IndexByteArrayOp_Char      args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res IndexByteArrayOp_WideChar  args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res IndexByteArrayOp_Int       args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Word      args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Addr      args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _      res IndexByteArrayOp_Float     args = doIndexByteArrayOp Nothing f32 res args
-emitPrimOp _      res IndexByteArrayOp_Double    args = doIndexByteArrayOp Nothing f64 res args
-emitPrimOp dflags res IndexByteArrayOp_StablePtr args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res IndexByteArrayOp_Int8      args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexByteArrayOp_Int16     args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
-emitPrimOp dflags res IndexByteArrayOp_Int32     args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
-emitPrimOp _      res IndexByteArrayOp_Int64     args = doIndexByteArrayOp Nothing b64  res args
-emitPrimOp dflags res IndexByteArrayOp_Word8     args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res IndexByteArrayOp_Word16    args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
-emitPrimOp dflags res IndexByteArrayOp_Word32    args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
-emitPrimOp _      res IndexByteArrayOp_Word64    args = doIndexByteArrayOp Nothing b64  res args
+emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp _      res IndexByteArrayOp_FloatX4          args = doIndexByteArrayOp   Nothing vec4f32 res args
+emitPrimOp _      res IndexByteArrayOp_FloatAsFloatX4   args = doIndexByteArrayOpAs Nothing vec4f32 f32 res args
+emitPrimOp _      res IndexByteArrayOp_DoubleX2         args = doIndexByteArrayOp   Nothing vec2f64 res args
+emitPrimOp _      res IndexByteArrayOp_DoubleAsDoubleX2 args = doIndexByteArrayOpAs Nothing vec2f64 f64 res args
+emitPrimOp _      res IndexByteArrayOp_Int32X4          args = doIndexByteArrayOp   Nothing vec4b32 res args
+emitPrimOp _      res IndexByteArrayOp_Int32AsInt32X4   args = doIndexByteArrayOpAs Nothing vec4b32 b32 res args
+emitPrimOp _      res IndexByteArrayOp_Int64X2          args = doIndexByteArrayOp   Nothing vec2b64 res args
+emitPrimOp _      res IndexByteArrayOp_Int64AsInt64X2   args = doIndexByteArrayOpAs Nothing vec2b64 b64 res args
 
 -- ReadXXXArray, identical to IndexXXXArray.
 
-emitPrimOp dflags res ReadByteArrayOp_Char       args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8 res args
-emitPrimOp dflags res ReadByteArrayOp_WideChar   args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32 res args
-emitPrimOp dflags res ReadByteArrayOp_Int        args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Word       args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Addr       args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp _      res ReadByteArrayOp_Float      args = doIndexByteArrayOp Nothing f32 res args
-emitPrimOp _      res ReadByteArrayOp_Double     args = doIndexByteArrayOp Nothing f64 res args
-emitPrimOp dflags res ReadByteArrayOp_StablePtr  args = doIndexByteArrayOp Nothing (bWord dflags) res args
-emitPrimOp dflags res ReadByteArrayOp_Int8       args = doIndexByteArrayOp (Just (mo_s_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadByteArrayOp_Int16      args = doIndexByteArrayOp (Just (mo_s_16ToWord dflags)) b16  res args
-emitPrimOp dflags res ReadByteArrayOp_Int32      args = doIndexByteArrayOp (Just (mo_s_32ToWord dflags)) b32  res args
-emitPrimOp _      res ReadByteArrayOp_Int64      args = doIndexByteArrayOp Nothing b64  res args
-emitPrimOp dflags res ReadByteArrayOp_Word8      args = doIndexByteArrayOp (Just (mo_u_8ToWord dflags)) b8  res args
-emitPrimOp dflags res ReadByteArrayOp_Word16     args = doIndexByteArrayOp (Just (mo_u_16ToWord dflags)) b16  res args
-emitPrimOp dflags res ReadByteArrayOp_Word32     args = doIndexByteArrayOp (Just (mo_u_32ToWord dflags)) b32  res args
-emitPrimOp _      res ReadByteArrayOp_Word64     args = doIndexByteArrayOp Nothing b64  res args
+emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp _      res ReadByteArrayOp_FloatX4          args = doIndexByteArrayOp   Nothing vec4f32 res args
+emitPrimOp _      res ReadByteArrayOp_FloatAsFloatX4   args = doIndexByteArrayOpAs Nothing vec4f32 f32 res args
+emitPrimOp _      res ReadByteArrayOp_DoubleX2         args = doIndexByteArrayOp   Nothing vec2f64 res args
+emitPrimOp _      res ReadByteArrayOp_DoubleAsDoubleX2 args = doIndexByteArrayOpAs Nothing vec2f64 f64 res args
+emitPrimOp _      res ReadByteArrayOp_Int32X4          args = doIndexByteArrayOp   Nothing vec4b32 res args
+emitPrimOp _      res ReadByteArrayOp_Int32AsInt32X4   args = doIndexByteArrayOpAs Nothing vec4b32 b32 res args
+emitPrimOp _      res ReadByteArrayOp_Int64X2          args = doIndexByteArrayOp   Nothing vec2b64 res args
+emitPrimOp _      res ReadByteArrayOp_Int64AsInt64X2   args = doIndexByteArrayOpAs Nothing vec2b64 b64 res args
 
 -- WriteXXXoffAddr
 
-emitPrimOp dflags res WriteOffAddrOp_Char       args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteOffAddrOp_WideChar   args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteOffAddrOp_Int        args = doWriteOffAddrOp Nothing res args
-emitPrimOp _      res WriteOffAddrOp_Word       args = doWriteOffAddrOp Nothing res args
-emitPrimOp _      res WriteOffAddrOp_Addr       args = doWriteOffAddrOp Nothing res args
-emitPrimOp _      res WriteOffAddrOp_Float      args = doWriteOffAddrOp Nothing res args
-emitPrimOp _      res WriteOffAddrOp_Double     args = doWriteOffAddrOp Nothing res args
-emitPrimOp _      res WriteOffAddrOp_StablePtr  args = doWriteOffAddrOp Nothing res args
-emitPrimOp dflags res WriteOffAddrOp_Int8       args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteOffAddrOp_Int16      args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
-emitPrimOp dflags res WriteOffAddrOp_Int32      args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteOffAddrOp_Int64      args = doWriteOffAddrOp Nothing res args
-emitPrimOp dflags res WriteOffAddrOp_Word8      args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteOffAddrOp_Word16     args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) res args
-emitPrimOp dflags res WriteOffAddrOp_Word32     args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteOffAddrOp_Word64     args = doWriteOffAddrOp Nothing res args
+emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args
+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args
+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args
+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args
+emitPrimOp _      res WriteOffAddrOp_FloatX4          args = doWriteOffAddrOp Nothing vec4f32 res args
+emitPrimOp _      res WriteOffAddrOp_FloatAsFloatX4   args = doWriteOffAddrOp Nothing f32 res args
+emitPrimOp _      res WriteOffAddrOp_DoubleX2         args = doWriteOffAddrOp Nothing vec2f64 res args
+emitPrimOp _      res WriteOffAddrOp_DoubleAsDoubleX2 args = doWriteOffAddrOp Nothing f64 res args
+emitPrimOp _      res WriteOffAddrOp_Int32X4          args = doWriteOffAddrOp Nothing vec4b32 res args
+emitPrimOp _      res WriteOffAddrOp_Int32AsInt32X4   args = doWriteOffAddrOp Nothing b32 res args
+emitPrimOp _      res WriteOffAddrOp_Int64X2          args = doWriteOffAddrOp Nothing vec2b64 res args
+emitPrimOp _      res WriteOffAddrOp_Int64AsInt64X2   args = doWriteOffAddrOp Nothing b64 res args
 
 -- WriteXXXArray
 
-emitPrimOp dflags res WriteByteArrayOp_Char      args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteByteArrayOp_WideChar  args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteByteArrayOp_Int       args = doWriteByteArrayOp Nothing res args
-emitPrimOp _      res WriteByteArrayOp_Word      args = doWriteByteArrayOp Nothing res args
-emitPrimOp _      res WriteByteArrayOp_Addr      args = doWriteByteArrayOp Nothing res args
-emitPrimOp _      res WriteByteArrayOp_Float     args = doWriteByteArrayOp Nothing res args
-emitPrimOp _      res WriteByteArrayOp_Double    args = doWriteByteArrayOp Nothing res args
-emitPrimOp _      res WriteByteArrayOp_StablePtr args = doWriteByteArrayOp Nothing res args
-emitPrimOp dflags res WriteByteArrayOp_Int8      args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteByteArrayOp_Int16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
-emitPrimOp dflags res WriteByteArrayOp_Int32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteByteArrayOp_Int64     args = doWriteByteArrayOp Nothing  res args
-emitPrimOp dflags res WriteByteArrayOp_Word8     args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  res args
-emitPrimOp dflags res WriteByteArrayOp_Word16    args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) res args
-emitPrimOp dflags res WriteByteArrayOp_Word32    args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) res args
-emitPrimOp _      res WriteByteArrayOp_Word64    args = doWriteByteArrayOp Nothing res args
+emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args
+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args
+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args
+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args
+emitPrimOp _      res WriteByteArrayOp_FloatX4          args = doWriteByteArrayOp Nothing vec4f32 res args
+emitPrimOp _      res WriteByteArrayOp_FloatAsFloatX4   args = doWriteByteArrayOp Nothing f32 res args
+emitPrimOp _      res WriteByteArrayOp_DoubleX2         args = doWriteByteArrayOp Nothing vec2f64 res args
+emitPrimOp _      res WriteByteArrayOp_DoubleAsDoubleX2 args = doWriteByteArrayOp Nothing f64 res args
+emitPrimOp _      res WriteByteArrayOp_Int32X4          args = doWriteByteArrayOp Nothing vec4b32 res args
+emitPrimOp _      res WriteByteArrayOp_Int32AsInt32X4   args = doWriteByteArrayOp Nothing b32 res args
+emitPrimOp _      res WriteByteArrayOp_Int64X2          args = doWriteByteArrayOp Nothing vec2b64 res args
+emitPrimOp _      res WriteByteArrayOp_Int64AsInt64X2   args = doWriteByteArrayOp Nothing b64 res args
 
 -- Copying and setting byte arrays
 emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =
@@ -498,6 +555,84 @@ emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]
 emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]
                                             (MO_UF_Conv W64) [w]
 
+-- SIMD vector packing and unpacking
+emitPrimOp _ [res] FloatToFloatX4Op [e] =
+    doVecPackOp Nothing vec4f32 zero [e,e,e,e] res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 4 (CmmFloat 0 W32))
+
+emitPrimOp _ [res] FloatX4PackOp es@[_,_,_,_] =
+    doVecPackOp Nothing vec4f32 zero es res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 4 (CmmFloat 0 W32))
+
+emitPrimOp _ res@[_,_,_,_] FloatX4UnpackOp [arg] =
+    doVecUnpackOp Nothing vec4f32 arg res
+
+emitPrimOp _ [res] FloatX4InsertOp [v,e,i] =
+    doVecInsertOp Nothing vec4f32 v e i res
+
+emitPrimOp _ [res] DoubleToDoubleX2Op [e] =
+    doVecPackOp Nothing vec2f64 zero [e,e] res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 2 (CmmFloat 0 W64))
+
+emitPrimOp _ [res] DoubleX2PackOp es@[_,_] =
+    doVecPackOp Nothing vec2f64 zero es res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 2 (CmmFloat 0 W64))
+
+emitPrimOp _ res@[_,_] DoubleX2UnpackOp [arg] =
+    doVecUnpackOp Nothing vec2f64 arg res
+
+emitPrimOp _ [res] DoubleX2InsertOp [v,e,i] =
+    doVecInsertOp Nothing vec2f64 v e i res
+
+emitPrimOp dflags [res] Int32ToInt32X4Op [e] =
+    doVecPackOp (Just (mo_WordTo32 dflags)) vec4b32 zero [e,e,e,e] res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 4 (CmmInt 0 W32))
+
+emitPrimOp dflags [res] Int32X4PackOp es@[_,_,_,_] =
+    doVecPackOp (Just (mo_WordTo32 dflags)) vec4b32 zero es res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 4 (CmmInt 0 W32))
+
+emitPrimOp dflags res@[_,_,_,_] Int32X4UnpackOp [arg] =
+    doVecUnpackOp (Just (mo_s_32ToWord dflags)) vec4b32 arg res
+
+emitPrimOp dflags [res] Int32X4InsertOp [v,e,i] =
+    doVecInsertOp (Just (mo_WordTo32 dflags)) vec4b32 v e i res
+
+emitPrimOp _ [res] Int64ToInt64X2Op [e] =
+    doVecPackOp Nothing vec2b64 zero [e,e] res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 2 (CmmInt 0 W64))
+
+emitPrimOp _ [res] Int64X2PackOp es@[_,_] =
+    doVecPackOp Nothing vec2b64 zero es res
+  where
+    zero :: CmmExpr
+    zero = CmmLit $ CmmVec (replicate 2 (CmmInt 0 W64))
+
+emitPrimOp _ res@[_,_] Int64X2UnpackOp [arg] =
+    doVecUnpackOp Nothing vec2b64 arg res
+
+emitPrimOp _ [res] Int64X2InsertOp [v,e,i] =
+    doVecInsertOp Nothing vec2b64 v e i res
+
+-- Prefetch
+emitPrimOp _ res PrefetchByteArrayOp        args = doPrefetchByteArrayOp res args
+emitPrimOp _ res PrefetchMutableByteArrayOp args = doPrefetchByteArrayOp res args
+emitPrimOp _ res PrefetchAddrOp             args = doPrefetchAddrOp res args
+
 -- The rest just translate straightforwardly
 emitPrimOp dflags [res] op [arg]
    | nopOp op
@@ -804,6 +939,34 @@ translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)
 translateOp _      FloatDivOp    = Just (MO_F_Quot W32)
 translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)
 
+-- Floating point vector ops
+
+translateOp _ FloatX4AddOp  = Just (MO_VF_Add  4 W32)
+translateOp _ FloatX4SubOp  = Just (MO_VF_Sub  4 W32)
+translateOp _ FloatX4MulOp  = Just (MO_VF_Mul  4 W32)
+translateOp _ FloatX4DivOp  = Just (MO_VF_Quot 4 W32)
+translateOp _ FloatX4NegOp  = Just (MO_VF_Neg  4 W32)
+
+translateOp _ DoubleX2AddOp  = Just (MO_VF_Add  2 W64)
+translateOp _ DoubleX2SubOp  = Just (MO_VF_Sub  2 W64)
+translateOp _ DoubleX2MulOp  = Just (MO_VF_Mul  2 W64)
+translateOp _ DoubleX2DivOp  = Just (MO_VF_Quot 2 W64)
+translateOp _ DoubleX2NegOp  = Just (MO_VF_Neg  2 W64)
+
+translateOp _ Int32X4AddOp   = Just (MO_V_Add   4 W32)
+translateOp _ Int32X4SubOp   = Just (MO_V_Sub   4 W32)
+translateOp _ Int32X4MulOp   = Just (MO_V_Mul   4 W32)
+translateOp _ Int32X4QuotOp  = Just (MO_VS_Quot 4 W32)
+translateOp _ Int32X4RemOp   = Just (MO_VS_Rem  4 W32)
+translateOp _ Int32X4NegOp   = Just (MO_VS_Neg  4 W32)
+
+translateOp _ Int64X2AddOp   = Just (MO_V_Add   2 W64)
+translateOp _ Int64X2SubOp   = Just (MO_V_Sub   2 W64)
+translateOp _ Int64X2MulOp   = Just (MO_V_Mul   2 W64)
+translateOp _ Int64X2QuotOp  = Just (MO_VS_Quot 2 W64)
+translateOp _ Int64X2RemOp   = Just (MO_VS_Rem  2 W64)
+translateOp _ Int64X2NegOp   = Just (MO_VS_Neg  2 W64)
+
 -- Conversions
 
 translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)
@@ -864,42 +1027,87 @@ callishOp _ = Nothing
 ------------------------------------------------------------------------------
 -- Helpers for translating various minor variants of array indexing.
 
-doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
+doIndexOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx
 doIndexOffAddrOp _ _ _ _
-   = panic "CgPrimOp: doIndexOffAddrOp"
-
-doIndexByteArrayOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode ()
+   = panic "StgCmmPrim: doIndexOffAddrOp"
+
+doIndexOffAddrOpAs :: Maybe MachOp
+                   -> CmmType
+                   -> CmmType 
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx
+doIndexOffAddrOpAs _ _ _ _ _
+   = panic "StgCmmPrim: doIndexOffAddrOpAs"
+
+doIndexByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
    = do dflags <- getDynFlags
-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx
-doIndexByteArrayOp _ _ _ _
-   = panic "CgPrimOp: doIndexByteArrayOp"
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx
+doIndexByteArrayOp _ _ _ _ 
+   = panic "StgCmmPrim: doIndexByteArrayOp"
+
+doIndexByteArrayOpAs :: Maybe MachOp
+                    -> CmmType
+                    -> CmmType 
+                    -> [LocalReg]
+                    -> [CmmExpr]
+                    -> FCode ()
+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx
+doIndexByteArrayOpAs _ _ _ _ _ 
+   = panic "StgCmmPrim: doIndexByteArrayOpAs"
 
-doReadPtrArrayOp ::  LocalReg -> CmmExpr -> CmmExpr -> FCode ()
+doReadPtrArrayOp :: LocalReg
+                 -> CmmExpr
+                 -> CmmExpr
+                 -> FCode ()
 doReadPtrArrayOp res addr idx
    = do dflags <- getDynFlags
-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr idx
-
-
-doWriteOffAddrOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
-doWriteOffAddrOp maybe_pre_write_cast [] [addr,idx,val]
-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx val
-doWriteOffAddrOp _ _ _
-   = panic "CgPrimOp: doWriteOffAddrOp"
+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx
 
-doWriteByteArrayOp :: Maybe MachOp -> [LocalReg] -> [CmmExpr] -> FCode ()
-doWriteByteArrayOp maybe_pre_write_cast [] [addr,idx,val]
+doWriteOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val
+doWriteOffAddrOp _ _ _ _
+   = panic "StgCmmPrim: doWriteOffAddrOp"
+
+doWriteByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
    = do dflags <- getDynFlags
-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx val
-doWriteByteArrayOp _ _ _
-   = panic "CgPrimOp: doWriteByteArrayOp"
+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val
+doWriteByteArrayOp _ _ _ _
+   = panic "StgCmmPrim: doWriteByteArrayOp"
 
-doWritePtrArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+doWritePtrArrayOp :: CmmExpr
+                  -> CmmExpr
+                  -> CmmExpr
+                  -> FCode ()
 doWritePtrArrayOp addr idx val
   = do dflags <- getDynFlags
-       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr idx val
+       let ty = cmmExprType dflags val
+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val
        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
   -- the write barrier.  We must write a byte into the mark table:
   -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
@@ -915,38 +1123,195 @@ loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
 loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
  where off = fixedHdrSize dflags * wORD_SIZE dflags + oFFSET_StgMutArrPtrs_ptrs dflags
 
-mkBasicIndexedRead :: ByteOff -> Maybe MachOp -> CmmType
-                   -> LocalReg -> CmmExpr -> CmmExpr -> FCode ()
-mkBasicIndexedRead off Nothing read_rep res base idx
+mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
+                   -> Maybe MachOp -- Optional result cast
+                   -> CmmType      -- Type of element we are accessing
+                   -> LocalReg     -- Destination
+                   -> CmmExpr      -- Base address
+                   -> CmmType      -- Type of element by which we are indexing
+                   -> CmmExpr      -- Index
+                   -> FCode ()
+mkBasicIndexedRead off Nothing ty res base idx_ty idx
    = do dflags <- getDynFlags
-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off read_rep base idx)
-mkBasicIndexedRead off (Just cast) read_rep res base idx
+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)
+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx
    = do dflags <- getDynFlags
         emitAssign (CmmLocal res) (CmmMachOp cast [
-                                   cmmLoadIndexOffExpr dflags off read_rep base idx])
-
-mkBasicIndexedWrite :: ByteOff -> Maybe MachOp
-                   -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-mkBasicIndexedWrite off Nothing base idx val
+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])
+
+mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
+                    -> Maybe MachOp -- Optional value cast
+                    -> CmmExpr      -- Base address
+                    -> CmmType      -- Type of element by which we are indexing
+                    -> CmmExpr      -- Index
+                    -> CmmExpr      -- Value to write
+                    -> FCode ()
+mkBasicIndexedWrite off Nothing base idx_ty idx val
    = do dflags <- getDynFlags
-        emitStore (cmmIndexOffExpr dflags off (typeWidth (cmmExprType dflags val)) base idx) val
-mkBasicIndexedWrite off (Just cast) base idx val
-   = mkBasicIndexedWrite off Nothing base idx (CmmMachOp cast [val])
+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val
+mkBasicIndexedWrite off (Just cast) base idx_ty idx val
+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
 
 -- ----------------------------------------------------------------------------
 -- Misc utils
 
-cmmIndexOffExpr :: DynFlags -> ByteOff -> Width -> CmmExpr -> CmmExpr -> CmmExpr
+cmmIndexOffExpr :: DynFlags
+                -> ByteOff  -- Initial offset in bytes
+                -> Width    -- Width of element by which we are indexing
+                -> CmmExpr  -- Base address
+                -> CmmExpr  -- Index
+                -> CmmExpr
 cmmIndexOffExpr dflags off width base idx
    = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx
 
-cmmLoadIndexOffExpr :: DynFlags -> ByteOff -> CmmType -> CmmExpr -> CmmExpr -> CmmExpr
-cmmLoadIndexOffExpr dflags off ty base idx
-   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth ty) base idx) ty
+cmmLoadIndexOffExpr :: DynFlags
+                    -> ByteOff  -- Initial offset in bytes
+                    -> CmmType  -- Type of element we are accessing
+                    -> CmmExpr  -- Base address
+                    -> CmmType  -- Type of element by which we are indexing
+                    -> CmmExpr  -- Index
+                    -> CmmExpr
+cmmLoadIndexOffExpr dflags off ty base idx_ty idx
+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty
 
 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
 
+------------------------------------------------------------------------------
+-- Helpers for translating vector packing and unpacking.
+
+doVecPackOp :: Maybe MachOp  -- Cast from element to vector component
+            -> CmmType       -- Type of vector
+            -> CmmExpr       -- Initial vector
+            -> [CmmExpr]     -- Elements
+            -> CmmFormal     -- Destination for result
+            -> FCode ()
+doVecPackOp maybe_pre_write_cast ty z es res = do
+    dst <- newTemp ty
+    emitAssign (CmmLocal dst) z
+    vecPack dst es 0
+  where
+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()
+    vecPack src [] _ =
+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))
+
+    vecPack src (e : es) i = do
+        dst <- newTemp ty
+        if isFloatType (vecElemType ty)
+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast e, iLit])
+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast 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
+              -> CmmExpr       -- Vector
+              -> [CmmFormal]   -- Element results
+              -> FCode ()
+doVecUnpackOp maybe_post_read_cast ty e res =
+    vecUnpack res 0
+  where
+    vecUnpack :: [CmmFormal] -> Int -> FCode ()
+    vecUnpack [] _ =
+        return ()
+
+    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]))
+        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
+              -> 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
+    dflags <- getDynFlags
+    -- vector indices are always 32-bits
+    let idx' :: CmmExpr
+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) 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'])
+  where
+    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)
+
+------------------------------------------------------------------------------
+-- Helpers for translating prefetching.
+
+doPrefetchByteArrayOp :: [LocalReg]
+                      -> [CmmExpr]
+                      -> FCode ()
+doPrefetchByteArrayOp res [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicPrefetch (arrWordsHdrSize dflags) res addr idx
+doPrefetchByteArrayOp _ _
+   = panic "StgCmmPrim: doPrefetchByteArrayOp"
+
+doPrefetchAddrOp :: [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doPrefetchAddrOp res [addr,idx]
+   = mkBasicPrefetch 0 res addr idx
+doPrefetchAddrOp _ _
+   = panic "StgCmmPrim: doPrefetchAddrOp"
+
+mkBasicPrefetch :: ByteOff      -- Initial offset in bytes
+                -> [LocalReg]   -- Destination
+                -> CmmExpr      -- Base address
+                -> CmmExpr      -- Index
+                -> FCode ()
+mkBasicPrefetch off res base idx
+   = do dflags <- getDynFlags
+        emitPrimCall [] MO_Prefetch_Data [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]
+        case res of
+          []    -> return ()
+          [reg] -> emitAssign (CmmLocal reg) base
+          _     -> panic "StgCmmPrim: mkBasicPrefetch"
+
 -- ----------------------------------------------------------------------------
 -- Copying byte arrays
 
index 50b834b..6b9e3e8 100644 (file)
@@ -202,7 +202,7 @@ slightly more complicated, does) turn into
 
    blah = op (\eta. ($dfList dCInt |> sym co) eta)
 
-and now it is *much* harder for the op/$dfList rule to fire, becuase
+and now it is *much* harder for the op/$dfList rule to fire, because
 exprIsConApp_maybe won't hold of the argument to op.  I considered
 trying to *make* it hold, but it's tricky and I gave up.
 
index d2bb6ed..2a11723 100644 (file)
@@ -328,12 +328,11 @@ breaker, which is perfectly inlinable.
 vectsFreeVars :: [CoreVect] -> VarSet
 vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
   where
-    vectFreeVars (Vect   _ Nothing)    = noFVs
-    vectFreeVars (Vect   _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
-    vectFreeVars (NoVect _)            = noFVs
-    vectFreeVars (VectType _ _ _)      = noFVs
-    vectFreeVars (VectClass _)         = noFVs
-    vectFreeVars (VectInst _)          = noFVs
+    vectFreeVars (Vect   _ rhs)   = expr_fvs rhs isLocalId emptyVarSet
+    vectFreeVars (NoVect _)       = noFVs
+    vectFreeVars (VectType _ _ _) = noFVs
+    vectFreeVars (VectClass _)    = noFVs
+    vectFreeVars (VectInst _)     = noFVs
       -- this function is only concerned with values, not types
 \end{code}
 
index ac3be95..0e9bcce 100644 (file)
@@ -144,7 +144,7 @@ lintCoreBindings binds
     -- allow this at top level:
     --    M.n{r3}  = ...
     --    M.n{r29} = ...
-    -- becuase they both get the same linker symbol
+    -- because they both get the same linker symbol
     ext_dups = snd (removeDups ord_ext (map Var.varName binders))
     ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
                   , Just m2 <- nameModule_maybe n2
@@ -1303,12 +1303,12 @@ mkKindErrMsg tyvar arg_ty
 
 mkArityMsg :: Id -> MsgDoc
 mkArityMsg binder
-  = vcat [hsep [ptext (sLit "Demand type has "),
-                     ppr (dmdTypeDepth dmd_ty),
-                     ptext (sLit " arguments, rhs has "),
-                     ppr (idArity binder),
-                     ptext (sLit "arguments, "),
-                    ppr binder],
+  = vcat [hsep [ptext (sLit "Demand type has"),
+                       ppr (dmdTypeDepth dmd_ty),
+                       ptext (sLit "arguments, rhs has"),
+                       ppr (idArity binder),
+                       ptext (sLit "arguments,"),
+               ppr binder],
              hsep [ptext (sLit "Binder's strictness signature:"), ppr dmd_ty]
 
          ]
index d8a1d2e..4f6883a 100644 (file)
@@ -436,7 +436,7 @@ substBind subst (Rec pairs) = (subst', Rec (bndrs' `zip` rhss'))
 
 \begin{code}
 -- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply
--- by running over the bindings with an empty substitution, becuase substitution
+-- by running over the bindings with an empty substitution, because substitution
 -- returns a result that has no-shadowing guaranteed.
 --
 -- (Actually, within a single /type/ there might still be shadowing, because 
@@ -750,12 +750,11 @@ substVects subst = map (substVect subst)
 
 ------------------
 substVect :: Subst -> CoreVect -> CoreVect
-substVect _subst (Vect   v Nothing)    = Vect v Nothing
-substVect subst  (Vect   v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
-substVect _subst vd@(NoVect _)         = vd
-substVect _subst vd@(VectType _ _ _)   = vd
-substVect _subst vd@(VectClass _)      = vd
-substVect _subst vd@(VectInst _)       = vd
+substVect subst  (Vect v rhs)        = Vect v (simpleOptExprWith subst rhs)
+substVect _subst vd@(NoVect _)       = vd
+substVect _subst vd@(VectType _ _ _) = vd
+substVect _subst vd@(VectClass _)    = vd
+substVect _subst vd@(VectInst _)     = vd
 
 ------------------
 substVarSet :: Subst -> VarSet -> VarSet
@@ -868,7 +867,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 -- We also inline bindings that bind a Eq# box: see
 -- See Note [Optimise coercion boxes agressively].
 --
--- The result is NOT guaranteed occurence-analysed, becuase
+-- The result is NOT guaranteed occurence-analysed, because
 -- in  (let x = y in ....) we substitute for x; so y's occ-info
 -- may change radically
 
@@ -901,7 +900,7 @@ simpleOptPgm dflags this_mod binds rules vects
        ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
   where
     occ_anald_binds  = occurAnalysePgm this_mod (\_ -> False) {- No rules active -}
-                                       rules vects binds
+                                       rules vects emptyVarEnv binds
     (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
                        
     do_one (subst, binds') bind 
index 6423c7e..6bd25fd 100644 (file)
@@ -31,7 +31,7 @@ module CoreSyn (
        mkFloatLit, mkFloatLitFloat,
        mkDoubleLit, mkDoubleLitDouble,
        
-       mkConApp, mkTyBind, mkCoBind,
+       mkConApp, mkConApp2, mkTyBind, mkCoBind,
        varToCoreExpr, varsToCoreExprs,
 
         isId, cmpAltCon, cmpAlt, ltAlt,
@@ -629,11 +629,11 @@ Representation of desugared vectorisation declarations that are fed to the vecto
 'ModGuts').
 
 \begin{code}
-data CoreVect = Vect      Id   (Maybe CoreExpr)
+data CoreVect = Vect      Id   CoreExpr
               | NoVect    Id
               | VectType  Bool TyCon (Maybe TyCon)
               | VectClass TyCon                     -- class tycon
-              | VectInst  Id                        -- instance dfun (always SCALAR)
+              | VectInst  Id                        -- instance dfun (always SCALAR)  !!!FIXME: should be superfluous now
 \end{code}
 
 
@@ -1133,6 +1133,11 @@ mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
+mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b
+mkConApp2 con tys arg_ids = Var (dataConWorkId con) 
+                            `mkApps` map Type tys
+                            `mkApps` map varToCoreExpr arg_ids
+
 
 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
index 9b527e7..6726087 100644 (file)
@@ -525,7 +525,7 @@ There used to be a gruesome test for (hasNoBinding v) in the
 Var case:
         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 The idea here is that a constructor worker, like \$wJust, is
-really short for (\x -> \$wJust x), becuase \$wJust has no binding.
+really short for (\x -> \$wJust x), because \$wJust has no binding.
 So it should be treated like a lambda.  Ditto unsaturated primops.
 But now constructor workers are not "have-no-binding" Ids.  And
 completely un-applied primops and foreign-call Ids are sufficiently
index 4877ec7..fa1cde9 100644 (file)
@@ -242,7 +242,7 @@ ppr_case_pat (DataAlt dc) args
     tc = dataConTyCon dc
 
 ppr_case_pat con args
-  = ppr con <+> sep (map ppr_bndr args)
+  = ppr con <+> (fsep (map ppr_bndr args))
   where
     ppr_bndr = pprBndr CaseBind
 
@@ -507,8 +507,7 @@ instance Outputable id => Outputable (Tickish id) where
 
 \begin{code}
 instance Outputable CoreVect where
-  ppr (Vect     var Nothing)         = ptext (sLit "VECTORISE SCALAR") <+> ppr var
-  ppr (Vect     var (Just e))        = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
+  ppr (Vect     var e)               = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
                                          4 (pprCoreExpr e)
   ppr (NoVect   var)                 = ptext (sLit "NOVECTORISE") <+> ppr var
   ppr (VectType False var Nothing)   = ptext (sLit "VECTORISE type") <+> ppr var
index 4ca4385..24ee560 100644 (file)
@@ -4,11 +4,6 @@
 
 \begin{code}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
 
 module PprExternalCore () where
 
index c4afc5b..133f0e1 100644 (file)
@@ -576,7 +576,7 @@ addTickHsExpr (HsWrap w e) =
                 (addTickHsExpr e)       -- explicitly no tick on inside
 
 addTickHsExpr e@(HsType _) = return e
-addTickHsExpr HsHole = panic "addTickHsExpr.HsHole"
+addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
 
 -- Others dhould never happen in expression content.
 addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
index 9a73893..ea6e7b5 100644 (file)
@@ -371,7 +371,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
                Right (final_bndrs, fn_id, args) -> do
        
        { let is_local = isLocalId fn_id
-               -- NB: isLocalId is False of implicit Ids.  This is good becuase
+               -- NB: isLocalId is False of implicit Ids.  This is good because
                -- we don't want to attach rules to the bindings of implicit Ids, 
                -- because they don't show up in the bindings until just before code gen
              fn_name   = idName fn_id
@@ -430,7 +430,7 @@ the rule is precisly to optimise them:
 dsVect :: LVectDecl Id -> DsM CoreVect
 dsVect (L loc (HsVect (L _ v) rhs))
   = putSrcSpanDs loc $ 
-    do { rhs' <- fmapMaybeM dsLExpr rhs
+    do { rhs' <- dsLExpr rhs
        ; return $ Vect v rhs'
        }
 dsVect (L _loc (HsNoVect (L _ v)))
index a392d74..41172e1 100644 (file)
@@ -662,8 +662,8 @@ It's true that this *is* a more specialised type, but the rule
 we get is something like this:
        f_spec d = f
        RULE: f = f_spec d
-Note that the rule is bogus, becuase it mentions a 'd' that is
-not bound on the LHS!  But it's a silly specialisation anyway, becuase
+Note that the rule is bogus, because it mentions a 'd' that is
+not bound on the LHS!  But it's a silly specialisation anyway, because
 the constraint is unused.  We could bind 'd' to (error "unused")
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
index b5e38c8..c0f5019 100644 (file)
@@ -19,6 +19,7 @@ module DsCCall
        , unboxArg
        , boxResult
        , resultWrapper
+        , splitDataProductType_maybe
        ) where
 
 #include "HsVersions.h"
@@ -191,7 +192,7 @@ unboxArg arg
        pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
   where
     arg_ty                                     = exprType arg
-    maybe_product_type                                 = splitProductType_maybe arg_ty
+    maybe_product_type                                 = splitDataProductType_maybe arg_ty
     is_product_type                            = maybeToBool maybe_product_type
     Just (_, _, data_con, data_con_arg_tys)    = maybe_product_type
     data_con_arity                             = dataConSourceArity data_con
@@ -357,7 +358,7 @@ resultWrapper result_ty
 
   -- Data types with a single constructor, which has a single arg
   -- This includes types like Ptr and ForeignPtr
-  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
+  | Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
     dataConSourceArity data_con == 1
   = do dflags <- getDynFlags
        let
@@ -391,3 +392,43 @@ maybeNarrow dflags tycon
         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
   | otherwise                    = id
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{Splitting products}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+-- | Extract the type constructor, type argument, data constructor and it's
+-- /representation/ argument types from a type if it is a product type.
+--
+-- Precisely, we return @Just@ for any type that is all of:
+--
+--  * Concrete (i.e. constructors visible)
+--
+--  * Single-constructor
+--
+--  * Not existentially quantified
+--
+-- Whether the type is a @data@ type or a @newtype@
+splitDataProductType_maybe
+       :: Type                         -- ^ A product type, perhaps
+       -> Maybe (TyCon,                -- The type constructor
+                 [Type],               -- Type args of the tycon
+                 DataCon,              -- The data constructor
+                 [Type])               -- Its /representation/ arg types
+
+       -- Rejecing existentials is conservative.  Maybe some things
+       -- could be made to work with them, but I'm not going to sweat
+       -- it through till someone finds it's important.
+
+splitDataProductType_maybe ty
+  | Just (tycon, ty_args) <- splitTyConApp_maybe ty
+  , Just con <- isDataProductTyCon_maybe tycon
+  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)
+  | otherwise
+  = Nothing
+\end{code}
+
+
index d0b71ed..cfda20a 100644 (file)
@@ -213,7 +213,7 @@ dsExpr (HsLamCase arg matches)
 dsExpr (HsApp fun arg)
   = mkCoreAppDs <$> dsLExpr fun <*>  dsLExpr arg
 
-dsExpr HsHole = panic "dsExpr: HsHole"
+dsExpr (HsUnboundVar _) = panic "dsExpr: HsUnboundVar"
 \end{code}
 
 Note [Desugaring vars]
@@ -820,7 +820,7 @@ conversionNames
   = [ toIntegerName, toRationalName
     , fromIntegralName, realToFracName ]
  -- We can't easily add fromIntegerName, fromRationalName,
- -- becuase they are generated by literals
+ -- because they are generated by literals
 \end{code}
 
 %************************************************************************
index bf06be1..9be8e96 100644 (file)
@@ -766,7 +766,7 @@ getPrimTyOf ty
   -- Except for Bool, the types we are interested in have a single constructor
   -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
   | otherwise =
-  case splitProductType_maybe rep_ty of
+  case splitDataProductType_maybe rep_ty of
      Just (_, _, data_con, [prim_ty]) ->
         ASSERT(dataConSourceArity data_con == 1)
         ASSERT2(isUnLiftedType prim_ty, ppr prim_ty)
index 04ffb76..9a9f89d 100644 (file)
@@ -8,7 +8,7 @@
 -- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
 --
 -- It also defines a bunch of knownKeyNames, in the same way as is done
--- in prelude/PrelNames.  It's much more convenient to do it here, becuase
+-- in prelude/PrelNames.  It's much more convenient to do it here, because
 -- otherwise we have to recompile PrelNames whenever we add a Name, which is
 -- a Royal Pain (triggers other recompilation).
 -----------------------------------------------------------------------------
@@ -351,7 +351,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
             -- appear in the resulting data structure
            --
            -- But we do NOT bring the binders of 'binds' into scope
-           -- becuase they are properly regarded as occurrences
+           -- because they are properly regarded as occurrences
            -- For example, the method names should be bound to
            -- the selector Ids, not to fresh names (Trac #5410)
            --
@@ -1876,7 +1876,7 @@ mk_string s = return $ HsString s
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
 repOverloadedLiteral (OverLit { ol_val = val})
   = do { lit <- mk_lit val; repLiteral lit }
-       -- The type Rational will be in the environment, becuase
+       -- The type Rational will be in the environment, because
        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
        -- and rationalL is sucked in when any TH stuff is used
 
index e05a175..15f76b6 100644 (file)
@@ -291,7 +291,7 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
   = MatchResult fail_flag mk_case
   where
     tycon = dataConTyCon con1
-       -- [Interesting: becuase of GADTs, we can't rely on the type of 
+       -- [Interesting: because of GADTs, we can't rely on the type of 
        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
 
        -- Stuff for newtype
index b9b6ec5..f3c9894 100644 (file)
@@ -113,7 +113,7 @@ dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
 Note [Literal short cut]
 ~~~~~~~~~~~~~~~~~~~~~~~~
 The type checker tries to do this short-cutting as early as possible, but 
-becuase of unification etc, more information is available to the desugarer.
+because of unification etc, more information is available to the desugarer.
 And where it's possible to generate the correct literal right away, it's
 much better do do so.
 
index 9631add..b63778c 100644 (file)
@@ -437,20 +437,22 @@ isLarge :: Word -> Bool
 isLarge n = n > 65535
 
 push_alts :: ArgRep -> Word16
-push_alts V = bci_PUSH_ALTS_V
-push_alts P = bci_PUSH_ALTS_P
-push_alts N = bci_PUSH_ALTS_N
-push_alts L = bci_PUSH_ALTS_L
-push_alts F = bci_PUSH_ALTS_F
-push_alts D = bci_PUSH_ALTS_D
+push_alts V   = bci_PUSH_ALTS_V
+push_alts P   = bci_PUSH_ALTS_P
+push_alts N   = bci_PUSH_ALTS_N
+push_alts L   = bci_PUSH_ALTS_L
+push_alts F   = bci_PUSH_ALTS_F
+push_alts D   = bci_PUSH_ALTS_D
+push_alts V16 = error "push_alts: vector"
 
 return_ubx :: ArgRep -> Word16
-return_ubx V = bci_RETURN_V
-return_ubx P = bci_RETURN_P
-return_ubx N = bci_RETURN_N
-return_ubx L = bci_RETURN_L
-return_ubx F = bci_RETURN_F
-return_ubx D = bci_RETURN_D
+return_ubx V   = bci_RETURN_V
+return_ubx P   = bci_RETURN_P
+return_ubx N   = bci_RETURN_N
+return_ubx L   = bci_RETURN_L
+return_ubx F   = bci_RETURN_F
+return_ubx D   = bci_RETURN_D
+return_ubx V16 = error "return_ubx: vector"
 
 -- Make lists of host-sized words for literals, so that when the
 -- words are placed in memory at increasing addresses, the
index 79c88fd..f152473 100644 (file)
@@ -174,7 +174,7 @@ mkJumpToAddr a
 
 #elif powerpc_TARGET_ARCH
 -- We'll use r12, for no particular reason.
--- 0xDEADBEEF stands for the adress:
+-- 0xDEADBEEF stands for the address:
 -- 3D80DEAD lis r12,0xDEAD
 -- 618CBEEF ori r12,r12,0xBEEF
 -- 7D8903A6 mtctr r12
index 6fcb7f4..06421dc 100644 (file)
@@ -240,7 +240,7 @@ lookupIE dflags ie con_nm
 
 linkFail :: String -> String -> IO a
 linkFail who what
-   = throwGhcException (ProgramError $
+   = throwGhcExceptionIO (ProgramError $
         unlines [ "",who
                 , "During interactive linking, GHCi couldn't find the following symbol:"
                 , ' ' : ' ' : what
index c939801..d3759f3 100644 (file)
@@ -44,8 +44,8 @@ prepForeignCall dflags cconv arg_types result_type
     let res_ty = primRepToFFIType dflags result_type
     r <- ffi_prep_cif cif abi (fromIntegral n_args) res_ty arg_arr
     if (r /= fFI_OK)
-       then throwGhcException (InstallationError
-                                   ("prepForeignCallFailed: " ++ show r))
+       then throwGhcExceptionIO (InstallationError
+                                     ("prepForeignCallFailed: " ++ show r))
        else return cif
 
 convToABI :: CCallConv -> C_ffi_abi
index 7d36337..03189e7 100644 (file)
@@ -172,7 +172,7 @@ getHValue hsc_env name = do
   pls <- modifyPLS $ \pls -> do
            if (isExternalName name) then do
              (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
-             if (failed ok) then throwGhcException (ProgramError "")
+             if (failed ok) then throwGhcExceptionIO (ProgramError "")
                             else return (pls', pls')
             else
              return (pls, pls)
@@ -321,7 +321,7 @@ reallyInitDynLinker dflags =
         ; ok <- resolveObjs
 
         ; if succeeded ok then maybePutStrLn dflags "done"
-          else throwGhcException (ProgramError "linking extra libraries/objects failed")
+          else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
 
         ; return pls
         }}
@@ -403,7 +403,7 @@ preloadLib dflags lib_paths framework_paths lib_spec
     preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
     preloadFailed sys_errmsg paths spec
        = do maybePutStr dflags "failed.\n"
-            throwGhcException $
+            throwGhcExceptionIO $
               CmdLineError (
                     "user specified .o/.so/.DLL could not be loaded ("
                     ++ sys_errmsg ++ ")\nWhilst trying to load:  "
@@ -455,7 +455,7 @@ linkExpr hsc_env span root_ul_bco
      -- Link the packages and modules required
    ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
    ; if failed ok then
-        throwGhcException (ProgramError "")
+        throwGhcExceptionIO (ProgramError "")
      else do {
 
      -- Link the expression itself
@@ -480,7 +480,7 @@ linkExpr hsc_env span root_ul_bco
         -- by default, so we can safely ignore them here.
 
 dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a
-dieWith dflags span msg = throwGhcException (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))
 
 
 checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool
@@ -566,7 +566,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
           mb_iface <- initIfaceCheck hsc_env $
                         loadInterface msg mod (ImportByUser False)
           iface <- case mb_iface of
-                    Maybes.Failed err      -> throwGhcException (ProgramError (showSDoc dflags err))
+                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
                     Maybes.Succeeded iface -> return iface
 
           when (mi_boot iface) $ link_boot_mod_error mod
@@ -594,7 +594,7 @@ getLinkDeps hsc_env hpt pls replace_osuf span mods
 
 
     link_boot_mod_error mod =
-        throwGhcException (ProgramError (showSDoc dflags (
+        throwGhcExceptionIO (ProgramError (showSDoc dflags (
             text "module" <+> ppr mod <+>
             text "cannot be linked; it is only available as a boot module")))
 
@@ -677,7 +677,7 @@ linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do
     -- Link the packages and modules required
     (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
     if failed ok
-      then throwGhcException (ProgramError "")
+      then throwGhcExceptionIO (ProgramError "")
       else do
 
     -- Link the expression itself
@@ -717,7 +717,7 @@ linkModule hsc_env mod = do
   initDynLinker (hsc_dflags hsc_env)
   modifyPLS_ $ \pls -> do
     (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
-    if (failed ok) then throwGhcException (ProgramError "could not link module")
+    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
       else return pls'
 \end{code}
 
@@ -1084,7 +1084,7 @@ linkPackages' dflags new_pks pls = do
              ; return (new_pkg : pkgs') }
 
         | otherwise
-        = throwGhcException (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
 
 
 linkPackage :: DynFlags -> PackageConfig -> IO ()
@@ -1140,7 +1140,7 @@ linkPackage dflags pkg
         maybePutStr dflags "linking ... "
         ok <- resolveObjs
         if succeeded ok then maybePutStrLn dflags "done."
-              else throwGhcException (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
+              else throwGhcExceptionIO (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
 
 -- we have already searched the filesystem; the strings passed to load_dyn
 -- can be passed directly to loadDLL.  They are either fully-qualified
@@ -1151,7 +1151,7 @@ load_dyn :: FilePath -> IO ()
 load_dyn dll = do r <- loadDLL dll
                   case r of
                     Nothing  -> return ()
-                    Just err -> throwGhcException (CmdLineError ("can't load .so/.DLL for: "
+                    Just err -> throwGhcExceptionIO (CmdLineError ("can't load .so/.DLL for: "
                                                               ++ dll ++ " (" ++ err ++ ")" ))
 
 loadFrameworks :: Platform -> InstalledPackageInfo_ ModuleName -> IO ()
@@ -1166,7 +1166,7 @@ loadFrameworks platform pkg
     load fw = do  r <- loadFramework fw_dirs fw
                   case r of
                     Nothing  -> return ()
-                    Just err -> throwGhcException (CmdLineError ("can't load framework: "
+                    Just err -> throwGhcExceptionIO (CmdLineError ("can't load framework: "
                                                         ++ fw ++ " (" ++ err ++ ")" ))
 
 -- Try to find an object file for a given library in the given paths.
index bd007a8..e5aea84 100644 (file)
@@ -634,7 +634,7 @@ pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type")
 data HsDataDefn name   -- The payload of a data type defn
                        -- Used *both* for vanilla data declarations,
                        --       *and* for data family instances
-  = -- | Declares a data type or newtype, giving its construcors
+  = -- | Declares a data type or newtype, giving its constructors
     -- @
     --  data/newtype T a = <constrs>
     --  data/newtype instance T [a] = <constrs>
@@ -1210,7 +1210,7 @@ type LVectDecl name = Located (VectDecl name)
 data VectDecl name
   = HsVect
       (Located name)
-      (Maybe (LHsExpr name))    -- 'Nothing' => SCALAR declaration
+      (LHsExpr name)
   | HsNoVect
       (Located name)
   | HsVectTypeIn                -- pre type-checking
@@ -1225,9 +1225,9 @@ data VectDecl name
       (Located name)
   | HsVectClassOut              -- post type-checking
       Class
-  | HsVectInstIn                -- pre type-checking (always SCALAR)
+  | HsVectInstIn                -- pre type-checking (always SCALAR)  !!!FIXME: should be superfluous now
       (LHsType name)
-  | HsVectInstOut               -- post type-checking (always SCALAR)
+  | HsVectInstOut               -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
       ClsInst
   deriving (Data, Typeable)
 
@@ -1247,9 +1247,7 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True
 lvectInstDecl _                       = False
 
 instance OutputableBndr name => Outputable (VectDecl name) where
-  ppr (HsVect v Nothing)
-    = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ]
-  ppr (HsVect v (Just rhs))
+  ppr (HsVect v rhs)
     = sep [text "{-# VECTORISE" <+> ppr v,
            nest 4 $ 
              pprExpr (unLoc rhs) <+> text "#-}" ]
index 2acc34e..c6f8bf1 100644 (file)
@@ -21,6 +21,7 @@ import HsBinds
 import TcEvidence
 import CoreSyn
 import Var
+import RdrName
 import Name
 import BasicTypes
 import DataCon
@@ -309,7 +310,7 @@ data HsExpr id
 
   |  HsWrap     HsWrapper    -- TRANSLATION
                 (HsExpr id)
-  |  HsHole
+  |  HsUnboundVar RdrName
   deriving (Data, Typeable)
 
 -- HsTupArg is used for tuple sections
@@ -575,8 +576,8 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
-ppr_expr HsHole
-  = ptext $ sLit "_"
+ppr_expr (HsUnboundVar nm)
+  = ppr nm
 
 \end{code}
 
@@ -612,7 +613,7 @@ hsExprNeedsParens (PArrSeq {})        = False
 hsExprNeedsParens (HsLit {})          = False
 hsExprNeedsParens (HsOverLit {})      = False
 hsExprNeedsParens (HsVar {})          = False
-hsExprNeedsParens (HsHole {})         = False
+hsExprNeedsParens (HsUnboundVar {})   = False
 hsExprNeedsParens (HsIPVar {})        = False
 hsExprNeedsParens (ExplicitTuple {})  = False
 hsExprNeedsParens (ExplicitList {})   = False
@@ -631,7 +632,7 @@ isAtomicHsExpr (HsVar {})     = True
 isAtomicHsExpr (HsLit {})     = True
 isAtomicHsExpr (HsOverLit {}) = True
 isAtomicHsExpr (HsIPVar {})   = True
-isAtomicHsExpr (HsHole {})    = True
+isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
 isAtomicHsExpr _              = False
index 7f9b24e..5a751f7 100644 (file)
@@ -96,7 +96,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
         errorOnMismatch what wanted got =
             -- This will be caught by readIface which will emit an error
             -- msg containing the iface module name.
-            when (wanted /= got) $ throwGhcException $ ProgramError
+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
                          (what ++ " (wanted " ++ show wanted
                                ++ ", got "    ++ show got ++ ")")
     bh <- Binary.readBinMem hi_path
index d8b3b95..2cc0c63 100644 (file)
@@ -206,7 +206,7 @@ type IfaceAnnTarget = AnnTarget OccName
 
 -- We only serialise the IdDetails of top-level Ids, and even then
 -- we only need a very limited selection.  Notably, none of the
--- implicit ones are needed here, becuase they are not put it
+-- implicit ones are needed here, because they are not put it
 -- interface files
 
 data IfaceIdDetails
index 783a0e9..a81b015 100644 (file)
@@ -172,7 +172,7 @@ loadInterfaceWithException doc mod_name where_from
   = do  { mb_iface <- loadInterface doc mod_name where_from
         ; dflags <- getDynFlags
         ; case mb_iface of 
-            Failed err      -> throwGhcException (ProgramError (showSDoc dflags err))
+            Failed err      -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
             Succeeded iface -> return iface }
 
 ------------------
@@ -790,18 +790,18 @@ pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
                     pprFix (occ,fix) = ppr fix <+> ppr occ 
 
 pprVectInfo :: IfaceVectInfo -> SDoc
-pprVectInfo (IfaceVectInfo { ifaceVectInfoVar          = vars
-                           , ifaceVectInfoTyCon        = tycons
-                           , ifaceVectInfoTyConReuse   = tyconsReuse
-                           , ifaceVectInfoScalarVars   = scalarVars
-                           , ifaceVectInfoScalarTyCons = scalarTyCons
+pprVectInfo (IfaceVectInfo { ifaceVectInfoVar            = vars
+                           , ifaceVectInfoTyCon          = tycons
+                           , ifaceVectInfoTyConReuse     = tyconsReuse
+                           , ifaceVectInfoParallelVars   = parallelVars
+                           , ifaceVectInfoParallelTyCons = parallelTyCons
                            }) = 
   vcat 
   [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars)
   , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons)
   , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse)
-  , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars)
-  , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons)
+  , ptext (sLit "parallel variables:") <+> hsep (map ppr parallelVars)
+  , ptext (sLit "parallel tycons:") <+> hsep (map ppr parallelTyCons)
   ]
 
 pprTrustInfo :: IfaceTrustInfo -> SDoc
index b7ebe91..19c76fb 100644 (file)
@@ -374,17 +374,17 @@ mkIface_ hsc_env maybe_old_fingerprint
 
      ifFamInstTcName = ifFamInstFam
 
-     flattenVectInfo (VectInfo { vectInfoVar          = vVar
-                               , vectInfoTyCon        = vTyCon
-                               , vectInfoScalarVars   = vScalarVars
-                               , vectInfoScalarTyCons = vScalarTyCons
+     flattenVectInfo (VectInfo { vectInfoVar            = vVar
+                               , vectInfoTyCon          = vTyCon
+                               , vectInfoParallelVars     = vParallelVars
+                               , vectInfoParallelTyCons = vParallelTyCons
                                }) = 
        IfaceVectInfo
-       { ifaceVectInfoVar          = [Var.varName v | (v, _  ) <- varEnvElts  vVar]
-       , ifaceVectInfoTyCon        = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
-       , ifaceVectInfoTyConReuse   = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
-       , ifaceVectInfoScalarVars   = [Var.varName v | v <- varSetElems vScalarVars]
-       , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons
+       { ifaceVectInfoVar            = [Var.varName v | (v, _  ) <- varEnvElts  vVar]
+       , ifaceVectInfoTyCon          = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t /= t_v]
+       , ifaceVectInfoTyConReuse     = [tyConName t   | (t, t_v) <- nameEnvElts vTyCon, t == t_v]
+       , ifaceVectInfoParallelVars   = [Var.varName v | v <- varSetElems vParallelVars]
+       , ifaceVectInfoParallelTyCons = nameSetToList vParallelTyCons
        } 
 
 -----------------------------
@@ -829,7 +829,7 @@ oldMD5 dflags bh = do
   let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
   r <- system cmd
   case r of
-    ExitFailure _ -> throwGhcException (PhaseFailed cmd r)
+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
     ExitSuccess -> do
         hash_str <- readFile tmp2
         return $! readHexFingerprint hash_str
index 947e4f1..e7676c8 100644 (file)
@@ -762,25 +762,25 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
 --
 tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
 tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
-                             { ifaceVectInfoVar          = vars
-                             , ifaceVectInfoTyCon        = tycons
-                             , ifaceVectInfoTyConReuse   = tyconsReuse
-                             , ifaceVectInfoScalarVars   = scalarVars
-                             , ifaceVectInfoScalarTyCons = scalarTyCons
+                             { ifaceVectInfoVar            = vars
+                             , ifaceVectInfoTyCon          = tycons
+                             , ifaceVectInfoTyConReuse     = tyconsReuse
+                             , ifaceVectInfoParallelVars   = parallelVars
+                             , ifaceVectInfoParallelTyCons = parallelTyCons
                              })
-  = do { let scalarTyConsSet = mkNameSet scalarTyCons
-       ; vVars       <- mapM vectVarMapping                  vars
+  = do { let parallelTyConsSet = mkNameSet parallelTyCons
+       ; vVars         <- mapM vectVarMapping                  vars
        ; let varsSet = mkVarSet (map fst vVars)
-       ; tyConRes1   <- mapM (vectTyConVectMapping varsSet)  tycons
-       ; tyConRes2   <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
-       ; vScalarVars <- mapM vectVar                         scalarVars
+       ; tyConRes1     <- mapM (vectTyConVectMapping varsSet)  tycons
+       ; tyConRes2     <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
+       ; vParallelVars <- mapM vectVar                         parallelVars
        ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
-                  { vectInfoVar          = mkVarEnv  vVars `extendVarEnvList` concat vScSels
-                  , vectInfoTyCon        = mkNameEnv vTyCons
-                  , vectInfoDataCon      = mkNameEnv (concat vDataCons)
-                  , vectInfoScalarVars   = mkVarSet  vScalarVars
-                  , vectInfoScalarTyCons = scalarTyConsSet
+                  { vectInfoVar            = mkVarEnv  vVars `extendVarEnvList` concat vScSels
+                  , vectInfoTyCon          = mkNameEnv vTyCons
+                  , vectInfoDataCon        = mkNameEnv (concat vDataCons)
+                  , vectInfoParallelVars   = mkVarSet  vParallelVars
+                  , vectInfoParallelTyCons = parallelTyConsSet
                   }
        }
   where
index d05a906..d69b88c 100644 (file)
@@ -43,7 +43,7 @@ module Llvm (
         -- ** Operations on the type system.
         isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
         getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
-        pLift, pLower, isInt, isFloat, isPointer, llvmWidthInBits,
+        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
 
         -- * Pretty Printing
         ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
index 9133447..f5f5eac 100644 (file)
@@ -198,6 +198,21 @@ data LlvmExpression
   | Compare LlvmCmpOp LlvmVar LlvmVar
 
   {- |
+    Extract a scalar element from a vector
+      * val: The vector
+      * idx: The index of the scalar within the vector
+  -}
+  | Extract LlvmVar LlvmVar
+
+  {- |
+    Insert a scalar element into a vector
+      * val:   The source vector
+      * elt:   The scalar to insert
+      * index: The index at which to insert the scalar
+  -}
+  | Insert LlvmVar LlvmVar LlvmVar
+
+  {- |
     Allocate amount * sizeof(tp) bytes on the heap
       * tp:     LlvmType to reserve room for
       * amount: The nr of tp's which must be allocated
index 2b2725d..a709a05 100644 (file)
@@ -230,6 +230,8 @@ ppLlvmExpression expr
         Call       tp fp args attrs -> ppCall tp fp args attrs
         Cast       op from to       -> ppCast op from to
         Compare    op left right    -> ppCmpOp op left right
+        Extract    vec idx          -> ppExtract vec idx
+        Insert     vec elt idx      -> ppInsert vec elt idx
         GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
         Load       ptr              -> ppLoad ptr
         Malloc     tp amount        -> ppMalloc tp amount
@@ -312,12 +314,31 @@ ppSyncOrdering SyncRelease   = text "release"
 ppSyncOrdering SyncAcqRel    = text "acq_rel"
 ppSyncOrdering SyncSeqCst    = text "seq_cst"
 
-ppLoad :: LlvmVar -> SDoc
-ppLoad var = text "load" <+> texts var
+-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
+-- we have no way of guaranteeing that this is true with GHC (we would need to
+-- modify the layout of the stack and closures, change the storage manager,
+-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
+-- unaligned. In the future we may be able to guarantee that certain vector
+-- access patterns are aligned, in which case we will need a more granular way
+-- of specifying alignment.
 
+ppLoad :: LlvmVar -> SDoc
+ppLoad var
+    | isVecPtrVar var = text "load" <+> texts var <>
+                        comma <+> text "align 1"
+    | otherwise       = text "load" <+> texts var
+  where
+    isVecPtrVar :: LlvmVar -> Bool
+    isVecPtrVar = isVector . pLower . getVarType
 
 ppStore :: LlvmVar -> LlvmVar -> SDoc
-ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
+ppStore val dst
+    | isVecPtrVar dst = text "store" <+> texts val <> comma <+> texts dst <>
+                        comma <+> text "align 1"
+    | otherwise       = text "store" <+> texts val <> comma <+> texts dst
+  where
+    isVecPtrVar :: LlvmVar -> Bool
+    isVecPtrVar = isVector . pLower . getVarType
 
 
 ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
@@ -383,6 +404,18 @@ ppAsm asm constraints rty vars sideeffect alignstack =
   in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
         <+> cons <> vars'
 
+ppExtract :: LlvmVar -> LlvmVar -> SDoc
+ppExtract vec idx =
+    text "extractelement"
+    <+> texts (getVarType vec) <+> text (getName vec) <> comma
+    <+> texts idx
+
+ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert vec elt idx =
+    text "insertelement"
+    <+> texts (getVarType vec) <+> text (getName vec) <> comma
+    <+> texts (getVarType elt) <+> text (getName elt) <> comma
+    <+> texts idx
 
 ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
 ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
index c4d9995..8b33c0b 100644 (file)
@@ -13,6 +13,7 @@ import Numeric
 
 import DynFlags
 import FastString
+import Outputable (panic)
 import Unique
 
 -- from NCG
@@ -34,33 +35,35 @@ type LlvmAlias = (LMString, LlvmType)
 
 -- | Llvm Types
 data LlvmType
-  = LMInt Int            -- ^ An integer with a given width in bits.
-  | LMFloat              -- ^ 32 bit floating point
-  | LMDouble             -- ^ 64 bit floating point
-  | LMFloat80            -- ^ 80 bit (x86 only) floating point
-  | LMFloat128           -- ^ 128 bit floating point
-  | LMPointer LlvmType   -- ^ A pointer to a 'LlvmType'
-  | LMArray Int LlvmType -- ^ An array of 'LlvmType'
-  | LMLabel              -- ^ A 'LlvmVar' can represent a label (address)
-  | LMVoid               -- ^ Void type
-  | LMStruct [LlvmType]  -- ^ Structure type
-  | LMAlias LlvmAlias    -- ^ A type alias
+  = LMInt Int             -- ^ An integer with a given width in bits.
+  | LMFloat               -- ^ 32 bit floating point
+  | LMDouble              -- ^ 64 bit floating point
+  | LMFloat80             -- ^ 80 bit (x86 only) floating point
+  | LMFloat128            -- ^ 128 bit floating point
+  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'
+  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'
+  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'
+  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)
+  | LMVoid                -- ^ Void type
+  | LMStruct [LlvmType]   -- ^ Structure type
+  | LMAlias LlvmAlias     -- ^ A type alias
 
   -- | Function type, used to create pointers to functions
   | LMFunction LlvmFunctionDecl
   deriving (Eq)
 
 instance Show LlvmType where
-  show (LMInt size    ) = "i" ++ show size
-  show (LMFloat       ) = "float"
-  show (LMDouble      ) = "double"
-  show (LMFloat80     ) = "x86_fp80"
-  show (LMFloat128    ) = "fp128"
-  show (LMPointer x   ) = show x ++ "*"
-  show (LMArray nr tp ) = "[" ++ show nr ++ " x " ++ show tp ++ "]"
-  show (LMLabel       ) = "label"
-  show (LMVoid        ) = "void"
-  show (LMStruct tys  ) = "<{" ++ (commaCat tys) ++ "}>"
+  show (LMInt size     ) = "i" ++ show size
+  show (LMFloat        ) = "float"
+  show (LMDouble       ) = "double"
+  show (LMFloat80      ) = "x86_fp80"
+  show (LMFloat128     ) = "fp128"
+  show (LMPointer x    ) = show x ++ "*"
+  show (LMArray nr tp  ) = "[" ++ show nr ++ " x " ++ show tp ++ "]"
+  show (LMVector nr tp ) = "<" ++ show nr ++ " x " ++ show tp ++ ">"
+  show (LMLabel        ) = "label"
+  show (LMVoid         ) = "void"
+  show (LMStruct tys   ) = "<{" ++ (commaCat tys) ++ "}>"
 
   show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
     = let varg' = case varg of
@@ -143,12 +146,15 @@ data LlvmLit
   | LMFloatLit Double LlvmType
   -- | Literal NULL, only applicable to pointer types
   | LMNullLit LlvmType
+  -- | Vector literal
+  | LMVectorLit [LlvmLit]
   -- | Undefined value, random bit pattern. Useful for optimisations.
   | LMUndefLit LlvmType
   deriving (Eq)
 
 instance Show LlvmLit where
-  show l = show (getLitType l) ++ " " ++ getLit l
+  show l@(LMVectorLit {}) = getLit l
+  show l                  = show (getLitType l) ++ " " ++ getLit l
 
 
 -- | Llvm Static Data.
@@ -233,6 +239,7 @@ getLit (LMIntLit i _         ) = show (fromInteger i :: Int)
 getLit (LMFloatLit r LMFloat ) = (dToStr . widenFp . narrowFp) r
 getLit (LMFloatLit r LMDouble) = dToStr r
 getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f
+getLit (LMVectorLit ls  ) = "< " ++ commaCat ls ++ " >"
 getLit (LMNullLit _     ) = "null"
 getLit (LMUndefLit _    ) = "undef"
 
@@ -245,10 +252,12 @@ getVarType (LMLitVar    l          ) = getLitType l
 
 -- | Return the 'LlvmType' of a 'LlvmLit'
 getLitType :: LlvmLit -> LlvmType
-getLitType (LMIntLit   _ t) = t
-getLitType (LMFloatLit _ t) = t
-getLitType (LMNullLit    t) = t
-getLitType (LMUndefLit   t) = t
+getLitType (LMIntLit    _ t) = t
+getLitType (LMFloatLit  _ t) = t
+getLitType (LMVectorLit [])  = panic "getLitType"
+getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))
+getLitType (LMNullLit     t) = t
+getLitType (LMUndefLit    t) = t
 
 -- | Return the 'LlvmType' of the 'LlvmStatic'
 getStatType :: LlvmStatic -> LlvmType
@@ -322,6 +331,11 @@ isPointer :: LlvmType -> Bool
 isPointer (LMPointer _) = True
 isPointer _             = False
 
+-- | Test if the given 'LlvmType' is an 'LMVector' construct
+isVector :: LlvmType -> Bool
+isVector (LMVector {}) = True
+isVector _             = False
+
 -- | Test if a 'LlvmVar' is global.
 isGlobal :: LlvmVar -> Bool
 isGlobal (LMGlobalVar _ _ _ _ _ _) = True
@@ -338,6 +352,7 @@ llvmWidthInBits _      (LMFloat128)    = 128
 -- it points to. We will go with the former for now.
 llvmWidthInBits dflags (LMPointer _)   = llvmWidthInBits dflags (llvmWord dflags)
 llvmWidthInBits dflags (LMArray _ _)   = llvmWidthInBits dflags (llvmWord dflags)
+llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty
 llvmWidthInBits _      LMLabel         = 0
 llvmWidthInBits _      LMVoid          = 0
 llvmWidthInBits dflags (LMStruct tys)  = sum $ map (llvmWidthInBits dflags) tys
index 45f20d7..bcfce34 100644 (file)
@@ -70,7 +70,8 @@ type UnresStatic = Either UnresLabel LlvmStatic
 
 -- | Translate a basic CmmType to an LlvmType.
 cmmToLlvmType :: CmmType -> LlvmType
-cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty
+cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
+                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
                  | otherwise      = widthToLlvmInt   $ typeWidth ty
 
 -- | Translate a Cmm Float Width to a LlvmType.
@@ -130,11 +131,12 @@ llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
 llvmFunArgs dflags live =
     map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
     where platform = targetPlatform dflags
-          isLive r = not (isFloat r) || r `elem` alwaysLive || r `elem` live
-          isPassed r = not (isFloat r) || isLive r
-          isFloat (FloatReg _)  = True
-          isFloat (DoubleReg _) = True
-          isFloat _             = False
+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
+          isPassed r = not (isSSE r) || isLive r
+          isSSE (FloatReg _)  = True
+          isSSE (DoubleReg _) = True
+          isSSE (XmmReg _)    = True
+          isSSE _             = False
 
 -- | Llvm standard fun attributes
 llvmStdFunAttrs :: [LlvmFuncAttr]
index 2893383..9159817 100644 (file)
@@ -40,7 +40,7 @@ type LlvmStatements = OrdList LlvmStatement
 --
 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
 genLlvmProc env (CmmProc infos lbl live graph) = do
-    let blocks = toBlockListEntryFirst graph
+    let blocks = toBlockListEntryFirstFalseFallthrough graph
     (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
     let info = mapLookup (g_entry graph) infos
         proc = CmmProc info lbl live (ListGraph lmblocks)
@@ -201,6 +201,25 @@ genCall _ (PrimTarget (MO_UF_Conv _)) [_] args =
     panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
     "Can only handle 1, given" ++ show (length args) ++ "."
 
+-- Handle prefetching data
+genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do
+    let dflags = getDflags env
+        argTy = [i8Ptr, i32, i32, i32]
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints' = zip args arg_hints
+    (env1, argVars, stmts1, top1) <- arg_vars env args_hints' ([], nilOL, [])
+    (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
+    (argVars', stmts3)            <- castVars dflags $ zip argVars argTy
+
+    let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1]
+        call = Expr $ Call StdCall fptr arguments []
+        stmts = stmts1 `appOL` stmts2 `appOL` stmts3
+                `appOL` trashStmts (getDflags env) `snocOL` call
+    return (env2, stmts, top1 ++ top2)
+
 -- Handle popcnt function specifically since GHC only really has i32 and i64
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
@@ -470,6 +489,7 @@ castVar dflags v t
                       (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
                       (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
                       (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
 
                       (vt, _) -> panic $ "castVars: Can't cast this type ("
                                   ++ show vt ++ ") to (" ++ show t ++ ")"
@@ -520,6 +540,8 @@ cmmPrimOpFunctions env mop
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ show (widthToLlvmInt w)
 
+    MO_Prefetch_Data -> fsLit "llvm.prefetch"
+
     MO_S_QuotRem {}  -> unsupported
     MO_U_QuotRem {}  -> unsupported
     MO_U_QuotRem2 {} -> unsupported
@@ -582,16 +604,21 @@ genAssign env reg val = do
     let stmts = stmts1 `appOL` stmts2
 
     let ty = (pLower . getVarType) vreg
-    case isPointer ty && getVarType vval == llvmWord dflags of
-         -- Some registers are pointer types, so need to cast value to pointer
-         True -> do
-             (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
-             let s2 = Store v vreg
-             return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+    case ty of
+      -- Some registers are pointer types, so need to cast value to pointer
+      LMPointer _ | getVarType vval == llvmWord dflags -> do
+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+          let s2 = Store v vreg
+          return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+      LMVector _ _ -> do
+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
+          let s2 = Store v vreg
+          return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
 
-         False -> do
-             let s1 = Store vval vreg
-             return (env2, stmts `snocOL` s1, top1 ++ top2)
+      _ -> do
+          let s1 = Store vval vreg
+          return (env2, stmts `snocOL` s1, top1 ++ top2)
 
 
 -- | CmmStore operation
@@ -879,6 +906,20 @@ genMachOp env _ op [x] = case op of
     MO_FF_Conv from to
         -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
 
+    MO_VS_Neg len w ->
+        let ty    = widthToLlvmInt w
+            vecty = LMVector len ty
+            all0  = LMIntLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_Sub
+
+    MO_VF_Neg len w ->
+        let ty    = widthToLlvmFloat w
+            vecty = LMVector len ty
+            all0  = LMFloatLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_FSub
+
     -- Handle unsupported cases explicitly so we get a warning
     -- of missing case when new MachOps added
     MO_Add _          -> panicOp
@@ -919,6 +960,24 @@ genMachOp env _ op [x] = case op of
     MO_Shl          _ -> panicOp
     MO_U_Shr        _ -> panicOp
     MO_S_Shr        _ -> panicOp
+    MO_V_Insert   _ _ -> panicOp
+    MO_V_Extract  _ _ -> panicOp
+  
+    MO_V_Add      _ _ -> panicOp
+    MO_V_Sub      _ _ -> panicOp
+    MO_V_Mul      _ _ -> panicOp
+
+    MO_VS_Quot    _ _ -> panicOp
+    MO_VS_Rem     _ _ -> panicOp
+    MO_VF_Insert  _ _ -> panicOp
+    MO_VF_Extract _ _ -> panicOp
+
+    MO_VF_Add     _ _ -> panicOp
+    MO_VF_Sub     _ _ -> panicOp
+    MO_VF_Mul     _ _ -> panicOp
+    MO_VF_Quot    _ _ -> panicOp
 
     where
         dflags = getDflags env
@@ -928,6 +987,12 @@ genMachOp env _ op [x] = case op of
             (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
             return (env', v1, stmts `snocOL` s1, top)
 
+        negateVec ty v2 negOp = do
+            (env', vx, stmts1, top) <- exprToVar env x
+            ([vx'], stmts2) <- castVars dflags [(vx, ty)]
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
+            return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+
         fiConv ty convOp = do
             (env', vx, stmts, top) <- exprToVar env x
             (v1, s1) <- doExpr ty $ Cast convOp vx ty
@@ -984,6 +1049,52 @@ genMachOp_fast env opt op r n e
 -- This handles all the cases not handle by the specialised genMachOp_fast.
 genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
 
+-- Element extraction
+genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do
+    (env1, vval, stmts1, top1) <- exprToVar env  val
+    (env2, vidx, stmts2, top2) <- exprToVar env1 idx
+    ([vval'], stmts3)          <- castVars dflags [(vval, LMVector l ty)]
+    (v1, s1)                   <- doExpr ty $ Extract vval' vidx
+    return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+  where
+    dflags = getDflags env
+    ty = widthToLlvmInt w
+
+genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do
+    (env1, vval, stmts1, top1) <- exprToVar env  val
+    (env2, vidx, stmts2, top2) <- exprToVar env1 idx
+    ([vval'], stmts3)          <- castVars dflags [(vval, LMVector l ty)]
+    (v1, s1)                   <- doExpr ty $ Extract vval' vidx
+    return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+  where
+    dflags = getDflags env
+    ty = widthToLlvmFloat w
+
+-- Element insertion
+genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do
+    (env1, vval, stmts1, top1) <- exprToVar env  val
+    (env2, velt, stmts2, top2) <- exprToVar env1 elt
+    (env3, vidx, stmts3, top3) <- exprToVar env2 idx
+    ([vval'], stmts4)          <- castVars dflags [(vval, ty)]
+    (v1, s1)                   <- doExpr ty $ Insert vval' velt vidx
+    return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
+            top1 ++ top2 ++ top3)
+  where
+    dflags = getDflags env
+    ty = LMVector l (widthToLlvmInt w)
+
+genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do
+    (env1, vval, stmts1, top1) <- exprToVar env  val
+    (env2, velt, stmts2, top2) <- exprToVar env1 elt
+    (env3, vidx, stmts3, top3) <- exprToVar env2 idx
+    ([vval'], stmts4)          <- castVars dflags [(vval, ty)]
+    (v1, s1)                   <- doExpr ty $ Insert vval' velt vidx
+    return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
+            top1 ++ top2 ++ top3)
+  where
+    dflags = getDflags env
+    ty = LMVector l (widthToLlvmFloat w)
+    
 -- Binary MachOp
 genMachOp_slow env opt op [x, y] = case op of
 
@@ -1033,6 +1144,18 @@ genMachOp_slow env opt op [x, y] = case op of
     MO_U_Shr _ -> genBinMach LM_MO_LShr
     MO_S_Shr _ -> genBinMach LM_MO_AShr
 
+    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+
+    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
+    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+
     MO_Not _       -> panicOp
     MO_S_Neg _     -> panicOp
     MO_F_Neg _     -> panicOp
@@ -1043,6 +1166,16 @@ genMachOp_slow env opt op [x, y] = case op of
     MO_UU_Conv _ _ -> panicOp
     MO_FF_Conv _ _ -> panicOp
 
+    MO_V_Insert  {} -> panicOp
+    MO_V_Extract {} -> panicOp
+
+    MO_VS_Neg {} -> panicOp
+
+    MO_VF_Insert  {} -> panicOp
+    MO_VF_Extract {} -> panicOp
+
+    MO_VF_Neg {} -> panicOp
+
     where
         dflags = getDflags env
 
@@ -1068,6 +1201,14 @@ genMachOp_slow env opt op [x, y] = case op of
                                     `snocOL` dy `snocOL` s1
                     return (env2, v1, allStmts, top1 ++ top2)
 
+        binCastLlvmOp ty binOp = do
+            (env1, vx, stmts1, top1) <- exprToVar env x
+            (env2, vy, stmts2, top2) <- exprToVar env1 y
+            ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)]
+            (v1, s1) <- doExpr ty $ binOp vx' vy'
+            return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
+                    top1 ++ top2)
+
         -- | Need to use EOption here as Cmm expects word size results from
         -- comparisons while LLVM return i1. Need to extend to llvmWord type
         -- if expected. See Note [Literals and branch conditions].
@@ -1086,6 +1227,8 @@ genMachOp_slow env opt op [x, y] = case op of
 
         genBinMach op = binLlvmOp getVarType (LlvmOp op)
 
+        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
+
         -- | Detect if overflow will occur in signed multiply of the two
         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
         -- implementation. Its much longer due to type information/safety.
@@ -1260,6 +1403,17 @@ genLit opt env (CmmInt i w)
 genLit _ env (CmmFloat r w)
   = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
               nilOL, [])
+genLit opt env (CmmVec ls)
+  = do llvmLits <- mapM toLlvmLit ls
+       return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+  where
+    toLlvmLit :: CmmLit -> UniqSM LlvmLit
+    toLlvmLit lit = do
+        (_, llvmLitVar, _, _) <- genLit opt env lit
+        case llvmLitVar of
+          LMLitVar llvmLit -> return llvmLit
+          _ -> panic "genLit"
 
 genLit _ env cmm@(CmmLabel l)
   = let dflags = getDflags env
@@ -1350,10 +1504,11 @@ funEpilogue env live = do
     dflags = getDflags env
     platform = targetPlatform dflags
     isLive r = r `elem` alwaysLive || r `elem` live
-    isPassed r = not (isFloat r) || isLive r
-    isFloat (FloatReg _)  = True
-    isFloat (DoubleReg _) = True
-    isFloat _             = False
+    isPassed r = not (isSSE r) || isLive r
+    isSSE (FloatReg _)  = True
+    isSSE (DoubleReg _) = True
+    isSSE (XmmReg _)    = True
+    isSSE _             = False
     loadExpr r | isLive r = do
         let reg  = lmGlobalRegVar dflags r
         (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
index fd0d7cc..83b5453 100644 (file)
@@ -171,6 +171,14 @@ genStaticLit (CmmInt i w)
 genStaticLit (CmmFloat r w)
     = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
 
+genStaticLit (CmmVec ls)
+    = Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls))
+  where
+    toLlvmLit :: CmmLit -> LlvmLit
+    toLlvmLit lit = case genStaticLit lit of
+                   Right (LMStaticLit llvmLit) -> llvmLit
+                   _ -> panic "genStaticLit"
+
 -- Leave unresolved, will fix later
 genStaticLit c@(CmmLabel        _    ) = Left $ c
 genStaticLit c@(CmmLabelOff     _   _) = Left $ c
index e6cfcb2..7271c2f 100644 (file)
@@ -55,6 +55,12 @@ lmGlobalReg dflags suf reg
         DoubleReg 4    -> doubleGlobal $ "D4" ++ suf
         DoubleReg 5    -> doubleGlobal $ "D5" ++ suf
         DoubleReg 6    -> doubleGlobal $ "D6" ++ suf
+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf
+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf
+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf
+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf
+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf
+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf
         _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
                                 ++ ") not supported!"
         -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
@@ -64,6 +70,7 @@ lmGlobalReg dflags suf reg
         ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)
         floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
         doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
 
 -- | A list of STG Registers that should always be considered alive
 alwaysLive :: [GlobalReg]
index 5a2b727..cda0b47 100644 (file)
@@ -64,8 +64,8 @@ doMkDependHS srcs = do
                  }
     _ <- GHC.setSessionDynFlags dflags
 
-    when (null (depSuffixes dflags)) $
-        throwGhcException (ProgramError "You must specify at least one -dep-suffix")
+    when (null (depSuffixes dflags)) $ liftIO $
+        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
 
     files <- liftIO $ beginMkDependHS dflags
 
@@ -193,7 +193,7 @@ processDeps :: DynFlags
 
 processDeps dflags _ _ _ _ (CyclicSCC nodes)
   =     -- There shouldn't be any cycles; report them
-    throwGhcException (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
+    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
 
 processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
   = do  { let extra_suffixes = depSuffixes dflags
index 81d0bc0..62ff424 100644 (file)
@@ -430,7 +430,7 @@ compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
 compileFile hsc_env stop_phase (src, mb_phase) = do
    exists <- doesFileExist src
    when (not exists) $
-        throwGhcException (CmdLineError ("does not exist: " ++ src))
+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
 
    let
         dflags = hsc_dflags hsc_env
@@ -542,7 +542,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
 
          let happensBefore' = happensBefore dflags
          when (not (start_phase `happensBefore'` stop_phase)) $
-               throwGhcException (UsageError
+               throwGhcExceptionIO (UsageError
                            ("cannot compile this file to desired target: "
                               ++ input_fn))
 
@@ -1895,8 +1895,8 @@ linkBinary dflags o_files dep_packages = do
 
     -- parallel only: move binary to another dir -- HWL
     success <- runPhase_MoveBinary dflags output_fn
-    if success then return ()
-               else throwGhcException (InstallationError ("cannot move binary"))
+    unless success $
+        throwGhcExceptionIO (InstallationError ("cannot move binary"))
 
 
 exeFileName :: DynFlags -> FilePath
@@ -2013,10 +2013,13 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
           [ "-D__SSE2__=1" | sse2 || sse4_2 ] ++
           [ "-D__SSE4_2__=1" | sse4_2 ]
 
+    backend_defs <- getBackendDefs dflags
+
     cpp_prog       (   map SysTools.Option verbFlags
                     ++ map SysTools.Option include_paths
                     ++ map SysTools.Option hsSourceCppOpts
                     ++ map SysTools.Option target_defs
+                    ++ map SysTools.Option backend_defs
                     ++ map SysTools.Option hscpp_opts
                     ++ map SysTools.Option cc_opts
                     ++ map SysTools.Option sse_defs
@@ -2035,6 +2038,14 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do
                        , SysTools.FileOption "" output_fn
                        ])
 
+getBackendDefs :: DynFlags -> IO [String]
+getBackendDefs dflags | hscTarget dflags == HscLlvm = do
+    llvmVer <- figureLlvmVersion dflags
+    return [ "-D__GLASGOW_HASKELL_LLVM__="++show llvmVer ]
+
+getBackendDefs _ =
+    return []
+
 hsSourceCppOpts :: [String]
 -- Default CPP defines in Haskell source
 hsSourceCppOpts =
index 5160f5a..2afe15f 100644 (file)
@@ -279,7 +279,7 @@ data GeneralFlag
    | Opt_DictsCheap
    | Opt_EnableRewriteRules             -- Apply rewrite rules during simplification
    | Opt_Vectorise
-   | Opt_AvoidVect
+   | Opt_VectorisationAvoidance
    | Opt_RegsGraph                      -- do graph coloring register allocation
    | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation
    | Opt_PedanticBottoms                -- Be picky about how we treat bottom
@@ -1795,16 +1795,17 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
 
   let ((leftover, errs, warns), dflags1)
           = runCmdLine (processArgs activeFlags args') dflags0
-  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
+  when (not (null errs)) $ liftIO $
+      throwGhcExceptionIO $ errorsToGhcException errs
 
   -- check for disabled flags in safe haskell
   let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1
       dflags3 = updateWays dflags2
       theWays = ways dflags3
 
-  unless (allowed_combination theWays) $
-      throwGhcException (CmdLineError ("combination not supported: "  ++
-                              intercalate "/" (map wayDesc theWays)))
+  unless (allowed_combination theWays) $ liftIO $
+      throwGhcExceptionIO (CmdLineError ("combination not supported: " ++
+                               intercalate "/" (map wayDesc theWays)))
 
   -- TODO: This is an ugly hack. Do something better.
   -- -fPIC affects the CMM code we generate, so if
@@ -1822,7 +1823,7 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
   when e.g. compiling a C file, only when compiling Haskell files.
   when doingDynamicToo $
       unless (isJust (outputFile dflags4) == isJust (dynOutputFile dflags4)) $
-          throwGhcException $ CmdLineError
+          liftIO $ throwGhcExceptionIO $ CmdLineError
               "With -dynamic-too, must give -dyno iff giving -o"
   -}
 
@@ -2452,7 +2453,7 @@ fFlags = [
   ( "run-cps",                          Opt_RunCPS, nop ),
   ( "run-cpsz",                         Opt_RunCPSZ, nop ),
   ( "vectorise",                        Opt_Vectorise, nop ),
-  ( "avoid-vect",                       Opt_AvoidVect, nop ),
+  ( "vectorisation-avoidance",          Opt_VectorisationAvoidance, nop ),
   ( "regs-graph",                       Opt_RegsGraph, nop ),
   ( "regs-iterative",                   Opt_RegsIterative, nop ),
   ( "llvm-tbaa",                        Opt_LlvmTBAA, nop), -- hidden flag
@@ -2760,6 +2761,7 @@ optLevelFlags
                 -- we want to make sure that the bindings for data
                 -- constructors are eta-expanded.  This is probably
                 -- a good thing anyway, but it seems fragile.
+    , ([0,1,2], Opt_VectorisationAvoidance)
     ]
 
 -- -----------------------------------------------------------------------------
index adcb0eb..889a09d 100644 (file)
@@ -35,7 +35,7 @@ import TyCon            ( TyCon )
 import Name             ( Name, nameModule_maybe )
 import Id               ( idType )
 import Module           ( Module, ModuleName )
-import Panic            ( GhcException(..), throwGhcException )
+import Panic
 import FastString
 import ErrUtils
 import Outputable
@@ -165,5 +165,5 @@ throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
 throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
 
 throwCmdLineError :: String -> IO a
-throwCmdLineError = throwGhcException . CmdLineError
+throwCmdLineError = throwGhcExceptionIO . CmdLineError
 #endif
index e0d6a96..3fd92ed 100644 (file)
@@ -52,6 +52,7 @@ import Data.IORef
 import Data.Ord
 import Data.Time
 import Control.Monad
+import Control.Monad.IO.Class
 import System.IO
 
 -- -----------------------------------------------------------------------------
@@ -360,6 +361,6 @@ prettyPrintGhcErrors dflags
                       PprProgramError str doc ->
                           pprDebugAndThen dflags pgmError str doc
                       _ ->
-                          throw e
+                          liftIO $ throwIO e
 \end{code}
 
index 35db120..ee40a13 100644 (file)
@@ -348,7 +348,7 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
                      Just StackOverflow ->
                          fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
                      _ -> case fromException exception of
-                          Just (ex :: ExitCode) -> throw ex
+                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
                           _ ->
                               fatalErrorMsg'' fm
                                   (show (Panic (show exception)))
@@ -618,7 +618,7 @@ guessTarget str Nothing
            then return (target (TargetModule (mkModuleName file)))
            else do
         dflags <- getDynFlags
-        throwGhcException
+        liftIO $ throwGhcExceptionIO
                  (ProgramError (showSDoc dflags $
                  text "target" <+> quotes (text file) <+> 
                  text "is not a module name or a source file"))
@@ -748,10 +748,10 @@ getModSummary mod = do
    mg <- liftM hsc_mod_graph getSession
    case [ ms | ms <- mg, ms_mod_name ms == mod, not (isBootSummary ms) ] of
      [] -> do dflags <- getDynFlags
-              throw $ mkApiErr dflags (text "Module not part of module graph")
+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
      [ms] -> return ms
      multiple -> do dflags <- getDynFlags
-                    throw $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
 
 -- | Parse a module.
 --
@@ -1213,7 +1213,7 @@ getModuleSourceAndFlags mod = do
   m <- getModSummary (moduleName mod)
   case ml_hs_file $ ms_location m of
     Nothing -> do dflags <- getDynFlags
-                  throw $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
+                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
     Just sourceFile -> do
         source <- liftIO $ hGetStringBuffer sourceFile
         return (sourceFile, source, ms_hspp_opts m)
@@ -1231,7 +1231,7 @@ getTokenStream mod = do
     POk _ ts  -> return ts
     PFailed span err ->
         do dflags <- getDynFlags
-           throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1244,7 +1244,7 @@ getRichTokenStream mod = do
     POk _ ts -> return $ addSourceToTokens startLoc source ts
     PFailed span err ->
         do dflags <- getDynFlags
-           throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1323,7 +1323,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
              err -> noModError dflags noSrcSpan mod_name err
 
 modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
-modNotLoadedError dflags m loc = throwGhcException $ CmdLineError $ showSDoc dflags $
+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
    text "module is not loaded:" <+> 
    quotes (ppr (moduleName m)) <+>
    parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
index 80227cd..81f338e 100644 (file)
@@ -1425,7 +1425,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
                 | otherwise                     = False
 
         when needs_preprocessing $
-           throwGhcException (ProgramError "buffer needs preprocesing; interactive check disabled")
+           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
 
         return (dflags', src_fn, buf)
 
index 2101fb5..9c1648c 100644 (file)
@@ -884,7 +884,7 @@ data CgGuts
         cg_binds     :: CoreProgram,
                 -- ^ The tidied main bindings, including
                 -- previously-implicit bindings for record and class
-                -- selectors, and data construtor wrappers.  But *not*
+                -- selectors, and data constructor wrappers.  But *not*
                 -- data constructor workers; reason: we we regard them
                 -- as part of the code-gen of tycons
 
@@ -1993,11 +1993,11 @@ on just the OccName easily in a Core pass.
 --
 data VectInfo
   = VectInfo
-    { vectInfoVar          :: VarEnv  (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
-    , vectInfoTyCon        :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@
-    , vectInfoDataCon      :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@
-    , vectInfoScalarVars   :: VarSet                      -- ^ set of purely scalar variables
-    , vectInfoScalarTyCons :: NameSet                     -- ^ set of scalar type constructors
+    { vectInfoVar            :: VarEnv  (Var    , Var  )    -- ^ @(f, f_v)@ keyed on @f@
+    , vectInfoTyCon          :: NameEnv (TyCon  , TyCon)    -- ^ @(T, T_v)@ keyed on @T@
+    , vectInfoDataCon        :: NameEnv (DataCon, DataCon)  -- ^ @(C, C_v)@ keyed on @C@
+    , vectInfoParallelVars   :: VarSet                      -- ^ set of parallel variables
+    , vectInfoParallelTyCons :: NameSet                     -- ^ set of parallel type constructors
     }
 
 -- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated
@@ -2011,18 +2011,18 @@ data VectInfo
 --
 data IfaceVectInfo
   = IfaceVectInfo
-    { ifaceVectInfoVar          :: [Name]  -- ^ All variables in here have a vectorised variant
-    , ifaceVectInfoTyCon        :: [Name]  -- ^ All 'TyCon's in here have a vectorised variant;
-                                           -- the name of the vectorised variant and those of its
-                                           -- data constructors are determined by
-                                           -- 'OccName.mkVectTyConOcc' and
-                                           -- 'OccName.mkVectDataConOcc'; the names of the
-                                           -- isomorphisms are determined by 'OccName.mkVectIsoOcc'
-    , ifaceVectInfoTyConReuse   :: [Name]  -- ^ The vectorised form of all the 'TyCon's in here
-                                           -- coincides with the unconverted form; the name of the
-                                           -- isomorphisms is determined by 'OccName.mkVectIsoOcc'
-    , ifaceVectInfoScalarVars   :: [Name]  -- iface version of 'vectInfoScalarVar'
-    , ifaceVectInfoScalarTyCons :: [Name]  -- iface version of 'vectInfoScalarTyCon'
+    { ifaceVectInfoVar            :: [Name]  -- ^ All variables in here have a vectorised variant
+    , ifaceVectInfoTyCon          :: [Name]  -- ^ All 'TyCon's in here have a vectorised variant;
+                                             -- the name of the vectorised variant and those of its
+                                             -- data constructors are determined by
+                                             -- 'OccName.mkVectTyConOcc' and
+                                             -- 'OccName.mkVectDataConOcc'; the names of the
+                                             -- isomorphisms are determined by 'OccName.mkVectIsoOcc'
+    , ifaceVectInfoTyConReuse     :: [Name]  -- ^ The vectorised form of all the 'TyCon's in here
+                                             -- coincides with the unconverted form; the name of the
+                                             -- isomorphisms is determined by 'OccName.mkVectIsoOcc'
+    , ifaceVectInfoParallelVars   :: [Name]  -- iface version of 'vectInfoParallelVar'
+    , ifaceVectInfoParallelTyCons :: [Name]  -- iface version of 'vectInfoParallelTyCon'
     }
 
 noVectInfo :: VectInfo
@@ -2031,11 +2031,11 @@ noVectInfo
 
 plusVectInfo :: VectInfo -> VectInfo -> VectInfo
 plusVectInfo vi1 vi2 =
-  VectInfo (vectInfoVar          vi1 `plusVarEnv`    vectInfoVar          vi2)
-           (vectInfoTyCon        vi1 `plusNameEnv`   vectInfoTyCon        vi2)
-           (vectInfoDataCon      vi1 `plusNameEnv`   vectInfoDataCon      vi2)
-           (vectInfoScalarVars   vi1 `unionVarSet`   vectInfoScalarVars   vi2)
-           (vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
+  VectInfo (vectInfoVar            vi1 `plusVarEnv`    vectInfoVar            vi2)
+           (vectInfoTyCon          vi1 `plusNameEnv`   vectInfoTyCon          vi2)
+           (vectInfoDataCon        vi1 `plusNameEnv`   vectInfoDataCon        vi2)
+           (vectInfoParallelVars   vi1 `unionVarSet`   vectInfoParallelVars   vi2)
+           (vectInfoParallelTyCons vi1 `unionNameSets` vectInfoParallelTyCons vi2)
 
 concatVectInfo :: [VectInfo] -> VectInfo
 concatVectInfo = foldr plusVectInfo noVectInfo
@@ -2049,11 +2049,11 @@ isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
 
 instance Outputable VectInfo where
   ppr info = vcat
-             [ ptext (sLit "variables     :") <+> ppr (vectInfoVar          info)
-             , ptext (sLit "tycons        :") <+> ppr (vectInfoTyCon        info)
-             , ptext (sLit "datacons      :") <+> ppr (vectInfoDataCon      info)
-             , ptext (sLit "scalar vars   :") <+> ppr (vectInfoScalarVars   info)
-             , ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
+             [ ptext (sLit "variables       :") <+> ppr (vectInfoVar            info)
+             , ptext (sLit "tycons          :") <+> ppr (vectInfoTyCon          info)
+             , ptext (sLit "datacons        :") <+> ppr (vectInfoDataCon        info)
+             , ptext (sLit "parallel vars   :") <+> ppr (vectInfoParallelVars   info)
+             , ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info)
              ]
 \end{code}
 
index 8d64900..1d74c63 100644 (file)
@@ -71,6 +71,7 @@ import Outputable
 import FastString
 import MonadUtils
 
+import System.Mem.Weak
 import System.Directory
 import Data.Dynamic
 import Data.Either
@@ -415,9 +416,19 @@ sandboxIO dflags statusMVar thing =
 --  * clients of the GHC API can terminate a runStmt in progress
 --    without knowing the ThreadId of the sandbox thread (#1381)
 --
+-- NB. use a weak pointer to the thread, so that the thread can still
+-- be considered deadlocked by the RTS and sent a BlockedIndefinitely
+-- exception.  A symptom of getting this wrong is that conc033(ghci)
+-- will hang.
+--
 redirectInterrupts :: ThreadId -> IO a -> IO a
 redirectInterrupts target wait
-  = wait `catch` \e -> do throwTo target (e :: SomeException); wait
+  = do wtid <- mkWeakThreadId target
+       wait `catch` \e -> do
+          m <- deRefWeak wtid
+          case m of
+            Nothing -> wait
+            Just target -> do throwTo target (e :: SomeException); wait
 
 -- We want to turn ^C into a break when -fbreak-on-exception is on,
 -- but it's an async exception and we only break for sync exceptions.
@@ -488,7 +499,8 @@ resume canLogSpan step
        resume = ic_resume ic
 
    case resume of
-     [] -> throwGhcException (ProgramError "not stopped at a breakpoint")
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
      (r:rs) -> do
         -- unbind the temporary locals by restoring the TypeEnv from
         -- before the breakpoint, and drop this Resume from the
@@ -546,16 +558,17 @@ moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan)
 moveHist fn = do
   hsc_env <- getSession
   case ic_resume (hsc_IC hsc_env) of
-     [] -> throwGhcException (ProgramError "not stopped at a breakpoint")
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
      (r:rs) -> do
         let ix = resumeHistoryIx r
             history = resumeHistory r
             new_ix = fn ix
         --
-        when (new_ix > length history) $
-           throwGhcException (ProgramError "no more logged breakpoints")
-        when (new_ix < 0) $
-           throwGhcException (ProgramError "already at the beginning of the history")
+        when (new_ix > length history) $ liftIO $
+           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
+        when (new_ix < 0) $ liftIO $
+           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
 
         let
           update_ic apStack mb_info = do
@@ -837,7 +850,8 @@ setContext imports
        ; let dflags = hsc_dflags hsc_env
        ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
        ; case all_env_err of
-           Left (mod, err) -> throwGhcException (formatError dflags mod err)
+           Left (mod, err) ->
+               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
            Right all_env -> do {
        ; let old_ic        = hsc_IC hsc_env
              final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env
index 1c04c2c..52361ce 100644 (file)
@@ -230,14 +230,14 @@ readPackageConfig dflags conf_file = do
        else do
             isfile <- doesFileExist conf_file
             when (not isfile) $
-              throwGhcException $ InstallationError $
+              throwGhcExceptionIO $ InstallationError $
                 "can't find a package database at " ++ conf_file
             debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
             str <- readFile conf_file
             case reads str of
                 [(configs, rest)]
                     | all isSpace rest -> return (map installedPackageInfoToPackageConfig configs)
-                _ -> throwGhcException $ InstallationError $
+                _ -> throwGhcExceptionIO $ InstallationError $
                         "invalid package database file " ++ conf_file
 
   let
@@ -410,12 +410,13 @@ packageFlagErr :: DynFlags
 -- for missing DPH package we emit a more helpful error message, because
 -- this may be the result of using -fdph-par or -fdph-seq.
 packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
-  = throwGhcException (CmdLineError (showSDoc dflags $ dph_err))
+  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
   where dph_err = text "the " <> text pkg <> text " package is not installed."
                   $$ text "To install it: \"cabal install dph\"."
         is_dph_package pkg = "dph" `isPrefixOf` pkg
 
-packageFlagErr dflags flag reasons = throwGhcException (CmdLineError (showSDoc dflags $ err))
+packageFlagErr dflags flag reasons
+  = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
   where err = text "cannot satisfy " <> ppr_flag <>
                 (if null reasons then empty else text ": ") $$
               nest 4 (ppr_reasons $$
@@ -983,7 +984,7 @@ closeDeps dflags pkg_map ipid_map ps
 throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
 throwErr dflags m
               = case m of
-                Failed e    -> throwGhcException (CmdLineError (showSDoc dflags e))
+                Failed e    -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
                 Succeeded r -> return r
 
 closeDepsErr :: PackageConfigMap
@@ -1017,7 +1018,7 @@ add_package pkg_db ipid_map ps (p, mb_parent)
 
 missingPackageErr :: DynFlags -> String -> IO a
 missingPackageErr dflags p
-    = throwGhcException (CmdLineError (showSDoc dflags (missingPackageMsg p)))
+    = throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
 
 missingPackageMsg :: String -> SDoc
 missingPackageMsg p = ptext (sLit "unknown package:") <+> text p
index 7684564..c982d14 100644 (file)
@@ -89,10 +89,10 @@ parseStaticFlagsFull :: [Flag IO] -> [Located String]
                      -> IO ([Located String], [Located String])
 parseStaticFlagsFull flagsAvailable args = do
   ready <- readIORef v_opt_C_ready
-  when ready $ throwGhcException (ProgramError "Too late for parseStaticFlags: call it before newSession")
+  when ready $ throwGhcExceptionIO (ProgramError "Too late for parseStaticFlags: call it before newSession")
 
   (leftover, errs, warns) <- processArgs flagsAvailable args
-  when (not (null errs)) $ throwGhcException $ errorsToGhcException errs
+  when (not (null errs)) $ throwGhcExceptionIO $ errorsToGhcException errs
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
index 28ff499..40a7a25 100644 (file)
@@ -353,7 +353,7 @@ findTopDir Nothing
          maybe_exec_dir <- getBaseDir
          case maybe_exec_dir of
              -- "Just" on Windows, "Nothing" on unix
-             Nothing  -> throwGhcException (InstallationError "missing -B<dir> option")
+             Nothing  -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
              Just dir -> return dir
 \end{code}
 
@@ -540,7 +540,7 @@ runClang dflags args = do
             text ("Error running clang! you need clang installed to use the" ++
                 "LLVM backend") $+$
             text "(or GHC tried to execute clang incorrectly)"
-        throw err
+        throwIO err
     )
 
 -- | Figure out which version of LLVM we are running this session
@@ -837,14 +837,14 @@ handleProc pgm phase_name proc = do
         -- the case of a missing program there will otherwise be no output
         -- at all.
        | n == 127  -> does_not_exist
-       | otherwise -> throwGhcException (PhaseFailed phase_name rc)
+       | otherwise -> throwGhcExceptionIO (PhaseFailed phase_name rc)
   where
     handler err =
        if IO.isDoesNotExistError err
           then does_not_exist
           else IO.ioError err
 
-    does_not_exist = throwGhcException (InstallationError ("could not execute: " ++ pgm))
+    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
 
 
 builderMainLoop :: DynFlags -> (String -> String) -> FilePath
@@ -976,7 +976,7 @@ traceCmd dflags phase_name cmd_line action
   where
     handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')
                               ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn))
-                              ; throwGhcException (PhaseFailed phase_name (ExitFailure 1)) }
+                              ; throwGhcExceptionIO (PhaseFailed phase_name (ExitFailure 1)) }
 \end{code}
 
 %************************************************************************
index 884f6ab..d49d437 100644 (file)
@@ -447,10 +447,10 @@ trimThing other_thing
 \begin{code}
 tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
 tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
-                                         , vectInfoScalarVars   = scalarVars
+                                         , vectInfoParallelVars = parallelVars
                                          })
   = info { vectInfoVar          = tidy_vars
-         , vectInfoScalarVars   = tidy_scalarVars
+         , vectInfoParallelVars = tidy_parallelVars
          }
   where
       -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
@@ -460,15 +460,18 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
                          , let tidy_var   = lookup_var var
                                tidy_var_v = lookup_var var_v
                          , isExportedId tidy_var
-                         , isExportedId tidy_var_v
+                         , isExternalId tidy_var_v
                          , isDataConWorkId var || not (isImplicitId var)
                          ]
 
-    tidy_scalarVars = mkVarSet [ lookup_var var
-                               | var <- varSetElems scalarVars
-                               , isGlobalId var || isExportedId var]
+    tidy_parallelVars = mkVarSet [ tidy_var
+                                 | var <- varSetElems parallelVars
+                                 , let tidy_var = lookup_var var
+                                 , isExternalId tidy_var]
 
     lookup_var var = lookupWithDefaultVarEnv var_env var var
+    
+    isExternalId = isExternalName . idName
 \end{code}
 
 Note [Don't attempt to trim data types]
@@ -476,7 +479,7 @@ Note [Don't attempt to trim data types]
 For some time GHC tried to avoid exporting the data constructors
 of a data type if it wasn't strictly necessary to do so; see Trac #835.
 But "strictly necessary" accumulated a longer and longer list 
-of execeptions, and finally I gave up the battle:
+of exceptions, and finally I gave up the battle:
 
     commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
     Author: Simon Peyton Jones <simonpj@microsoft.com>
@@ -525,7 +528,7 @@ Id still makes sense.]
 
 At one time I tried injecting the implicit bindings *early*, at the
 beginning of SimplCore.  But that gave rise to real difficulty,
-becuase GlobalIds are supposed to have *fixed* IdInfo, but the
+because GlobalIds are supposed to have *fixed* IdInfo, but the
 simplifier and other core-to-core passes mess with IdInfo all the
 time.  The straw that broke the camels back was when a class selector
 got the wrong arity -- ie the simplifier gave it arity 2, whereas
@@ -664,6 +667,9 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                 | omit_prags = ([], False)
                 | otherwise  = addExternal expose_all refined_id
 
+                -- add vectorised version if any exists
+          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc)
+          
                 -- 'idocc' is an *occurrence*, but we need to see the
                 -- unfolding in the *definition*; so look up in binder_set
           refined_id = case lookupVarSet binder_set idocc of
@@ -674,7 +680,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
           referrer' | isExportedId refined_id = refined_id
                     | otherwise               = referrer
       --
-      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
+      search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env'
 
   tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
                 -> IO (UnfoldEnv, TidyOccEnv)
index 58c3c75..71f0264 100644 (file)
@@ -27,7 +27,6 @@ import qualified SPARC.ShortcutJump
 import qualified SPARC.CodeGen.Expand
 
 import qualified PPC.CodeGen
-import qualified PPC.Cond
 import qualified PPC.Regs
 import qualified PPC.RegInfo
 import qualified PPC.Instr
@@ -148,7 +147,7 @@ data NcgImpl statics instr jumpDest = NcgImpl {
     ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr),
-    ncgMakeFarBranches        :: [NatBasicBlock instr] -> [NatBasicBlock instr]
+    ncgMakeFarBranches        :: BlockEnv CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr]
     }
 
 --------------------
@@ -191,7 +190,7 @@ x86_64NcgImpl dflags
        ,ncg_x86fp_kludge          = id
        ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
        ,ncgExpandTop              = id
-       ,ncgMakeFarBranches        = id
+       ,ncgMakeFarBranches        = const id
    }
     where platform = targetPlatform dflags
 
@@ -210,7 +209,7 @@ ppcNcgImpl dflags
        ,ncg_x86fp_kludge          = id
        ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform
        ,ncgExpandTop              = id
-       ,ncgMakeFarBranches        = makeFarBranches
+       ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches
    }
     where platform = targetPlatform dflags
 
@@ -229,7 +228,7 @@ sparcNcgImpl dflags
        ,ncg_x86fp_kludge          = id
        ,ncgAllocMoreStack         = noAllocMoreStack
        ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
-       ,ncgMakeFarBranches        = id
+       ,ncgMakeFarBranches        = const id
    }
 
 --
@@ -662,7 +661,7 @@ sequenceTop
 
 sequenceTop _       top@(CmmData _ _) = top
 sequenceTop ncgImpl (CmmProc info lbl live (ListGraph blocks)) =
-  CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
+  CmmProc info lbl live (ListGraph $ ncgMakeFarBranches ncgImpl info $ sequenceBlocks info blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -734,42 +733,6 @@ reorder id accum (b@(block,id',out) : rest)
 
 
 -- -----------------------------------------------------------------------------
--- Making far branches
-
--- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
--- big, we have to work around this limitation.
-
-makeFarBranches
-        :: [NatBasicBlock PPC.Instr.Instr]
-        -> [NatBasicBlock PPC.Instr.Instr]
-makeFarBranches blocks
-    | last blockAddresses < nearLimit = blocks
-    | otherwise = zipWith handleBlock blockAddresses blocks
-    where
-        blockAddresses = scanl (+) 0 $ map blockLen blocks
-        blockLen (BasicBlock _ instrs) = length instrs
-
-        handleBlock addr (BasicBlock id instrs)
-                = BasicBlock id (zipWith makeFar [addr..] instrs)
-
-        makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
-        makeFar addr (PPC.Instr.BCC cond tgt)
-            | abs (addr - targetAddr) >= nearLimit
-            = PPC.Instr.BCCFAR cond tgt
-            | otherwise
-            = PPC.Instr.BCC cond tgt
-            where Just targetAddr = lookupUFM blockAddressMap tgt
-        makeFar _ other            = other
-
-        nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
-                         -- distance, as we have a few pseudo-insns that are
-                         -- pretty-printed as multiple instructions,
-                         -- and it's just not worth the effort to calculate
-                         -- things exactly
-
-        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
-
--- -----------------------------------------------------------------------------
 -- Generate jump tables
 
 -- Analyzes all native code and generates data sections for all jump
index e9a5b43..92eff36 100644 (file)
@@ -1164,6 +1164,7 @@ genCCall' dflags gcp target dest_regs args0
                     MO_U_Mul2 {}     -> unsupported
                     MO_WriteBarrier  -> unsupported
                     MO_Touch         -> unsupported
+                    MO_Prefetch_Data -> unsupported
                 unsupported = panic ("outOfLineCmmOp: " ++ show mop
                                   ++ " not supported")
 
index 80b7556..937a427 100644 (file)
@@ -14,7 +14,8 @@ module PPC.Instr (
     RI(..),
     Instr(..),
     maxSpillSlots,
-    allocMoreStack
+    allocMoreStack,
+    makeFarBranches
 )
 
 where
@@ -31,11 +32,13 @@ import CodeGen.Platform
 import BlockId
 import DynFlags
 import Cmm
+import CmmInfo
 import FastString
 import CLabel
 import Outputable
 import Platform
 import FastBool
+import UniqFM (listToUFM, lookupUFM)
 import UniqSupply
 
 --------------------------------------------------------------------------------
@@ -505,3 +508,40 @@ ppc_mkJumpInstr id
 ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
 ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)
 ppc_takeRegRegMoveInstr _  = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches
+        :: BlockEnv CmmStatics
+        -> [NatBasicBlock Instr]
+        -> [NatBasicBlock Instr]
+makeFarBranches info_env blocks
+    | last blockAddresses < nearLimit = blocks
+    | otherwise = zipWith handleBlock blockAddresses blocks
+    where
+        blockAddresses = scanl (+) 0 $ map blockLen blocks
+        blockLen (BasicBlock _ instrs) = length instrs
+
+        handleBlock addr (BasicBlock id instrs)
+                = BasicBlock id (zipWith makeFar [addr..] instrs)
+
+        makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
+        makeFar addr (BCC cond tgt)
+            | abs (addr - targetAddr) >= nearLimit
+            = BCCFAR cond tgt
+            | otherwise
+            = BCC cond tgt
+            where Just targetAddr = lookupUFM blockAddressMap tgt
+        makeFar _ other            = other
+
+        -- 8192 instructions are allowed; let's keep some distance, as
+        -- we have a few pseudo-insns that are pretty-printed as
+        -- multiple instructions, and it's just not worth the effort
+        -- to calculate things exactly
+        nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW
+
+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
index 880b5c6..c6497e1 100644 (file)
@@ -656,6 +656,7 @@ outOfLineMachOp_table mop
         MO_U_Mul2 {}     -> unsupported
         MO_WriteBarrier  -> unsupported
         MO_Touch         -> unsupported
+        MO_Prefetch_Data -> unsupported
     where unsupported = panic ("outOfLineCmmOp: " ++ show mop
                             ++ " not supported here")
 
index d014709..c6cdd8a 100644 (file)
@@ -602,6 +602,22 @@ getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
       MO_FS_Conv from to -> coerceFP2Int from to x
       MO_SF_Conv from to -> coerceInt2FP from to x
 
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
       _other -> pprPanic "getRegister" (pprMachOp mop)
    where
         triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register
@@ -694,6 +710,22 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
       MO_U_Shr rep -> shift_code rep SHR x y {-False-}
       MO_S_Shr rep -> shift_code rep SAR x y {-False-}
 
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
       _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
   where
     --------------------
@@ -749,7 +781,7 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
       * so we can either:
         - do y first, put its result in a fresh tmp, then copy it to %ecx later
         - do y second and put its result into %ecx.  x gets placed in a fresh
-          tmp.  This is likely to be better, becuase the reg alloc can
+          tmp.  This is likely to be better, because the reg alloc can
           eliminate this reg->reg move here (it won't eliminate the other one,
           because the move is into the fixed %ecx).
     -}
@@ -884,7 +916,9 @@ getRegister' dflags _ (CmmLit lit)
            code dst = unitOL (MOV size (OpImm imm) (OpReg dst))
        return (Any size code)
 
-getRegister' _ _ other = pprPanic "getRegister(x86)" (ppr other)
+getRegister' _ _ other
+    | isVecExpr other  = needLlvm
+    | otherwise        = pprPanic "getRegister(x86)" (ppr other)
 
 
 intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
@@ -1623,6 +1657,8 @@ genCCall _ (PrimTarget MO_WriteBarrier) _ _ = return nilOL
 
 genCCall _ (PrimTarget MO_Touch) _ _ = return nilOL
 
+genCCall _ (PrimTarget MO_Prefetch_Data) _ _ = return nilOL
+
 genCCall is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
          args@[src] = do
     sse4_2 <- sse4_2Enabled
@@ -2292,6 +2328,7 @@ outOfLineCmmOp mop res args
               MO_U_Mul2 {}     -> unsupported
               MO_WriteBarrier  -> unsupported
               MO_Touch         -> unsupported
+              MO_Prefetch_Data -> unsupported
         unsupported = panic ("outOfLineCmmOp: " ++ show mop
                           ++ " not supported here")
 
@@ -2690,3 +2727,27 @@ sse2NegCode w x = do
         ]
   --
   return (Any sz code)
+
+isVecExpr :: CmmExpr -> Bool
+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True
+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True
+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True
+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True
+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True
+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True
+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True
+isVecExpr (CmmMachOp _ [e])                = isVecExpr e
+isVecExpr _                                = False
+
+needLlvm :: NatM a
+needLlvm =
+    sorry $ unlines ["The native code generator does not support vector"
+                    ,"instructions. Please use -fllvm."]
index c552b6a..597f6a5 100644 (file)
@@ -592,8 +592,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
         | '{-# DEPRECATED' deprecations '#-}'   { $2 }
         | '{-# WARNING' warnings '#-}'          { $2 }
         | '{-# RULES' rules '#-}'               { $2 }
-        | '{-# VECTORISE_SCALAR' qvar '#-}'     { unitOL $ LL $ VectD (HsVect       $2 Nothing) }
-        | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect       $2 (Just $4)) }
+        | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect       $2 $4) }
         | '{-# NOVECTORISE' qvar '#-}'          { unitOL $ LL $ VectD (HsNoVect     $2) }
         | '{-# VECTORISE' 'type' gtycon '#-}'     
                                                 { unitOL $ LL $ 
@@ -608,8 +607,6 @@ topdecl :: { OrdList (LHsDecl RdrName) }
                                                 { unitOL $ LL $ 
                                                     VectD (HsVectTypeIn True $3 (Just $5)) }
         | '{-# VECTORISE' 'class' gtycon '#-}'  { unitOL $ LL $ VectD (HsVectClassIn $3) }
-        | '{-# VECTORISE_SCALAR' 'instance' type '#-}'     
-                                                { unitOL $ LL $ VectD (HsVectInstIn $3) }
         | annotation { unitOL $1 }
         | decl                                  { unLoc $1 }
 
@@ -1358,14 +1355,14 @@ decl    :: { Located (OrdList (LHsDecl RdrName)) }
         : sigdecl               { $1 }
 
         | '!' aexp rhs          {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) };
-                                        pat <- checkPattern e;
+                                        pat <- checkPattern empty e;
                                         return $ LL $ unitOL $ LL $ ValD $
                                                PatBind pat (unLoc $3)
                                                        placeHolderType placeHolderNames (Nothing,[]) } }
                                 -- Turn it all into an expression so that
                                 -- checkPattern can check that bangs are enabled
 
-        | infixexp opt_sig rhs  {% do { r <- checkValDef $1 $2 $3;
+        | infixexp opt_sig rhs  {% do { r <- checkValDef empty $1 $2 $3;
                                         let { l = comb2 $1 $> };
                                         return $! (sL l (unitOL $! (sL l $ ValD r))) } }
         | docdecl               { LL $ unitOL $1 }
@@ -1465,7 +1462,7 @@ exp10 :: { LHsExpr RdrName }
                                                                       else HsPar $2 } }
 
         | 'proc' aexp '->' exp  
-                        {% checkPattern $2 >>= \ p -> 
+                        {% checkPattern empty $2 >>= \ p -> 
                             checkCommand $4 >>= \ cmd ->
                             return (LL $ HsProc p (LL $ HsCmdTop cmd [] 
                                                     placeHolderType undefined)) }
@@ -1548,7 +1545,7 @@ aexp2   :: { LHsExpr RdrName }
         | TH_TY_QUOTE gtycon    { LL $ HsBracket (VarBr False (unLoc $2)) }
         | '[|' exp '|]'         { LL $ HsBracket (ExpBr $2) }                       
         | '[t|' ctype '|]'      { LL $ HsBracket (TypBr $2) }                       
-        | '[p|' infixexp '|]'   {% checkPattern $2 >>= \p ->
+        | '[p|' infixexp '|]'   {% checkPattern empty $2 >>= \p ->
                                         return (LL $ HsBracket (PatBr p)) }
         | '[d|' cvtopbody '|]'  { LL $ HsBracket (DecBrL $2) }
         | quasiquote            { L1 (HsQuasiQuoteE (unLoc $1)) }
@@ -1750,12 +1747,16 @@ gdpat   :: { LGRHS RdrName (LHsExpr RdrName) }
 -- Bangs inside are parsed as infix operator applications, so that
 -- we parse them right when bang-patterns are off
 pat     :: { LPat RdrName }
-pat     :  exp                  {% checkPattern $1 }
-        | '!' aexp              {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+pat     :  exp                  {% checkPattern empty $1 }
+        | '!' aexp              {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+
+bindpat :: { LPat RdrName }
+bindpat :  exp                  {% checkPattern (text "Possibly caused by a missing 'do'?") $1 }
+        | '!' aexp              {% checkPattern (text "Possibly caused by a missing 'do'?") (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
 
 apat   :: { LPat RdrName }      
-apat    : aexp                  {% checkPattern $1 }
-        | '!' aexp              {% checkPattern (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
+apat    : aexp                  {% checkPattern empty $1 }
+        | '!' aexp              {% checkPattern empty (LL (SectionR (L1 (HsVar bang_RDR)) $2)) }
 
 apats  :: { [LPat RdrName] }
         : apat apats            { $1 : $2 }
@@ -1789,12 +1790,12 @@ maybe_stmt :: { Maybe (LStmt RdrName (LHsExpr RdrName)) }
         | {- nothing -}                 { Nothing }
 
 stmt  :: { LStmt RdrName (LHsExpr RdrName) }
-        : qual                              { $1 }
+        : qual                          { $1 }
         | 'rec' stmtlist                { LL $ mkRecStmt (unLoc $2) }
 
 qual  :: { LStmt RdrName (LHsExpr RdrName) }
-    : pat '<-' exp                      { LL $ mkBindStmt $1 $3 }
-    | exp                                   { L1 $ mkBodyStmt $1 }
+    : bindpat '<-' exp                  { LL $ mkBindStmt $1 $3 }
+    | exp                               { L1 $ mkBodyStmt $1 }
     | 'let' binds                       { LL $ LetStmt (unLoc $2) }
 
 -----------------------------------------------------------------------------
index 6bd8701..8c7b0a7 100644 (file)
@@ -542,35 +542,39 @@ checkContext (L l orig_t)
 -- We parse patterns as expressions and check for valid patterns below,
 -- converting the expression into a pattern at the same time.
 
-checkPattern :: LHsExpr RdrName -> P (LPat RdrName)
-checkPattern e = checkLPat e
+checkPattern :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
+checkPattern msg e = checkLPat msg e
 
-checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName]
-checkPatterns es = mapM checkPattern es
+checkPatterns :: SDoc -> [LHsExpr RdrName] -> P [LPat RdrName]
+checkPatterns msg es = mapM (checkPattern msg) es
 
-checkLPat :: LHsExpr RdrName -> P (LPat RdrName)
-checkLPat e@(L l _) = checkPat l e []
+checkLPat :: SDoc -> LHsExpr RdrName -> P (LPat RdrName)
+checkLPat msg e@(L l _) = checkPat msg l e []
 
-checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName)
-checkPat loc (L l (HsVar c)) args
+checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName]
+         -> P (LPat RdrName)
+checkPat _ loc (L l (HsVar c)) args
   | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args)))
-checkPat loc e args     -- OK to let this happen even if bang-patterns
+checkPat msg loc e args     -- OK to let this happen even if bang-patterns
                         -- are not enabled, because there is no valid
                         -- non-bang-pattern parse of (C ! e)
   | Just (e', args') <- splitBang e
-  = do  { args'' <- checkPatterns args'
-        ; checkPat loc e' (args'' ++ args) }
-checkPat loc (L _ (HsApp f x)) args
-  = do { x <- checkLPat x; checkPat loc f (x:args) }
-checkPat loc (L _ e) []
-  = do { pState <- getPState
-       ; p <- checkAPat (dflags pState) loc e
-       ; return (L loc p) }
-checkPat loc e _
-  = patFail loc (unLoc e)
-
-checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
-checkAPat dynflags loc e0 = case e0 of
+  = do  { args'' <- checkPatterns msg args'
+        ; checkPat msg loc e' (args'' ++ args) }
+checkPat msg loc (L _ (HsApp f e)) args
+  = do p <- checkLPat msg e
+       checkPat msg loc f (p : args)
+checkPat msg loc (L _ e) []
+  = do p <- checkAPat msg loc e
+       return (L loc p)
+checkPat msg loc e _
+  = patFail msg loc (unLoc e)
+
+checkAPat :: SDoc -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
+checkAPat msg loc e0 = do
+ pState <- getPState
+ let dynflags = dflags pState
+ case e0 of
    EWildPat -> return (WildPat placeHolderType)
    HsVar x  -> return (VarPat x)
    HsLit l  -> return (LitPat l)
@@ -585,14 +589,14 @@ checkAPat dynflags loc e0 = case e0 of
    SectionR (L _ (HsVar bang)) e        -- (! x)
         | bang == bang_RDR
         -> do { bang_on <- extension bangPatEnabled
-              ; if bang_on then checkLPat e >>= (return . BangPat)
+              ; if bang_on then checkLPat msg e >>= (return . BangPat)
                 else parseErrorSDoc loc (text "Illegal bang-pattern (use -XBangPatterns):" $$ ppr e0) }
 
-   ELazyPat e         -> checkLPat e >>= (return . LazyPat)
-   EAsPat n e         -> checkLPat e >>= (return . AsPat n)
+   ELazyPat e         -> checkLPat msg e >>= (return . LazyPat)
+   EAsPat n e         -> checkLPat msg e >>= (return . AsPat n)
    -- view pattern is well-formed if the pattern is
-   EViewPat expr patE -> checkLPat patE >>= (return . (\p -> ViewPat expr p placeHolderType))
-   ExprWithTySig e t  -> do e <- checkLPat e
+   EViewPat expr patE -> checkLPat msg patE >>= (return . (\p -> ViewPat expr p placeHolderType))
+   ExprWithTySig e t  -> do e <- checkLPat msg e
                             -- Pattern signatures are parsed as sigtypes,
                             -- but they aren't explicit forall points.  Hence
                             -- we have to remove the implicit forall here.
@@ -607,29 +611,29 @@ checkAPat dynflags loc e0 = case e0 of
                       | xopt Opt_NPlusKPatterns dynflags && (plus == plus_RDR)
                       -> return (mkNPlusKPat (L nloc n) lit)
 
-   OpApp l op _fix r  -> do l <- checkLPat l
-                            r <- checkLPat r
+   OpApp l op _fix r  -> do l <- checkLPat msg l
+                            r <- checkLPat msg r
                             case op of
                                L cl (HsVar c) | isDataOcc (rdrNameOcc c)
                                       -> return (ConPatIn (L cl c) (InfixCon l r))
-                               _ -> patFail loc e0
+                               _ -> patFail msg loc e0
 
-   HsPar e            -> checkLPat e >>= (return . ParPat)
-   ExplicitList _ es  -> do ps <- mapM checkLPat es
+   HsPar e            -> checkLPat msg e >>= (return . ParPat)
+   ExplicitList _ es  -> do ps <- mapM (checkLPat msg) es
                             return (ListPat ps placeHolderType)
-   ExplicitPArr _ es  -> do ps <- mapM checkLPat es
+   ExplicitPArr _ es  -> do ps <- mapM (checkLPat msg) es
                             return (PArrPat ps placeHolderType)
 
    ExplicitTuple es b
-     | all tupArgPresent es  -> do ps <- mapM checkLPat [e | Present e <- es]
+     | all tupArgPresent es  -> do ps <- mapM (checkLPat msg) [e | Present e <- es]
                                    return (TuplePat ps b placeHolderType)
      | otherwise -> parseErrorSDoc loc (text "Illegal tuple section in pattern:" $$ ppr e0)
 
    RecordCon c _ (HsRecFields fs dd)
-                      -> do fs <- mapM checkPatField fs
+                      -> do fs <- mapM (checkPatField msg) fs
                             return (ConPatIn c (RecCon (HsRecFields fs dd)))
    HsQuasiQuoteE q    -> return (QuasiQuotePat q)
-   _                  -> patFail loc e0
+   _                  -> patFail msg loc e0
 
 placeHolderPunRhs :: LHsExpr RdrName
 -- The RHS of a punned record field will be filled in by the renamer
@@ -641,42 +645,46 @@ plus_RDR = mkUnqual varName (fsLit "+") -- Hack
 bang_RDR = mkUnqual varName (fsLit "!") -- Hack
 pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
 
-checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
-checkPatField fld = do  { p <- checkLPat (hsRecFieldArg fld)
-                        ; return (fld { hsRecFieldArg = p }) }
+checkPatField :: SDoc -> HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
+checkPatField msg fld = do p <- checkLPat msg (hsRecFieldArg fld)
+                           return (fld { hsRecFieldArg = p })
 
-patFail :: SrcSpan -> HsExpr RdrName -> P a
-patFail loc e = parseErrorSDoc loc (text "Parse error in pattern:" <+> ppr e)
+patFail :: SDoc -> SrcSpan -> HsExpr RdrName -> P a
+patFail msg loc e = parseErrorSDoc loc err
+    where err = text "Parse error in pattern:" <+> ppr e
+             $$ msg
 
 
 ---------------------------------------------------------------------------
 -- Check Equation Syntax
 
-checkValDef :: LHsExpr RdrName
+checkValDef :: SDoc
+            -> LHsExpr RdrName
             -> Maybe (LHsType RdrName)
             -> Located (GRHSs RdrName (LHsExpr RdrName))
             -> P (HsBind RdrName)
 
-checkValDef lhs (Just sig) grhss
+checkValDef msg lhs (Just sig) grhss
         -- x :: ty = rhs  parses as a *pattern* binding
-  = checkPatBind (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
+  = checkPatBind msg (L (combineLocs lhs sig) (ExprWithTySig lhs sig)) grhss
 
-checkValDef lhs opt_sig grhss
+checkValDef msg lhs opt_sig grhss
   = do  { mb_fun <- isFunLhs lhs
         ; case mb_fun of
-            Just (fun, is_infix, pats) -> checkFunBind (getLoc lhs)
+            Just (fun, is_infix, pats) -> checkFunBind msg (getLoc lhs)
                                                 fun is_infix pats opt_sig grhss
-            Nothing -> checkPatBind lhs grhss }
+            Nothing -> checkPatBind msg lhs grhss }
 
-checkFunBind :: SrcSpan
+checkFunBind :: SDoc
+             -> SrcSpan
              -> Located RdrName
              -> Bool
              -> [LHsExpr RdrName]
              -> Maybe (LHsType RdrName)
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P (HsBind RdrName)
-checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
-  = do  ps <- checkPatterns pats
+checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
+  = do  ps <- checkPatterns msg pats
         let match_span = combineSrcSpans lhs_loc rhs_span
         return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
         -- The span of the match covers the entire equation.
@@ -688,11 +696,12 @@ makeFunBind fn is_infix ms
   = FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
               fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
 
-checkPatBind :: LHsExpr RdrName
+checkPatBind :: SDoc
+             -> LHsExpr RdrName
              -> Located (GRHSs RdrName (LHsExpr RdrName))
              -> P (HsBind RdrName)
-checkPatBind lhs (L _ grhss)
-  = do  { lhs <- checkPattern lhs
+checkPatBind msg lhs (L _ grhss)
+  = do  { lhs <- checkPattern msg lhs
         ; return (PatBind lhs grhss placeHolderType placeHolderNames
                     (Nothing,[])) }
 
index 261d102..03a95de 100644 (file)
@@ -1420,6 +1420,15 @@ typeNatAddTyFamNameKey    = mkPreludeTyConUnique 162
 typeNatMulTyFamNameKey    = mkPreludeTyConUnique 163
 typeNatExpTyFamNameKey    = mkPreludeTyConUnique 164
 
+-- SIMD vector types (Unique keys)
+floatX4PrimTyConKey, doubleX2PrimTyConKey, int32X4PrimTyConKey,
+  int64X2PrimTyConKey :: Unique
+
+floatX4PrimTyConKey  = mkPreludeTyConUnique 170
+doubleX2PrimTyConKey = mkPreludeTyConUnique 171
+int32X4PrimTyConKey  = mkPreludeTyConUnique 172
+int64X2PrimTyConKey  = mkPreludeTyConUnique 173
+
 ---------------- Template Haskell -------------------
 --      USES TyConUniques 200-299
 -----------------------------------------------------
index b21d546..2e55e49 100644 (file)
@@ -31,7 +31,7 @@ import PrimOp      ( PrimOp(..), tagToEnumKey )
 import TysWiredIn
 import TysPrim
 import TyCon       ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
-import DataCon     ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
+import DataCon     ( dataConTag, dataConTyCon, dataConWorkId )
 import CoreUtils   ( cheapEqExpr, exprIsHNF )
 import CoreUnfold  ( exprIsConApp_maybe )
 import Type
index 8b9cbf9..c59884b 100644 (file)
@@ -73,7 +73,13 @@ module TysPrim(
         eqPrimTyCon,            -- ty1 ~# ty2
 
        -- * Any
-       anyTy, anyTyCon, anyTypeOfKind
+       anyTy, anyTyCon, anyTypeOfKind,
+
+        -- * SIMD
+       floatX4PrimTyCon,               floatX4PrimTy,
+       doubleX2PrimTyCon,              doubleX2PrimTy,
+       int32X4PrimTyCon,               int32X4PrimTy,
+       int64X2PrimTyCon,               int64X2PrimTy
   ) where
 
 #include "HsVersions.h"
@@ -135,6 +141,11 @@ primTyCons
     , constraintKindTyCon
     , superKindTyCon
     , anyKindTyCon
+
+    , floatX4PrimTyCon
+    , doubleX2PrimTyCon
+    , int32X4PrimTyCon
+    , int64X2PrimTyCon
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
@@ -144,7 +155,7 @@ mkPrimTc fs unique tycon
                  (ATyCon tycon)        -- Relevant TyCon
                  UserSyntax            -- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, floatX4PrimTyConName, doubleX2PrimTyConName, int32X4PrimTyConName, int64X2PrimTyConName :: Name
 charPrimTyConName            = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName             = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName           = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -172,6 +183,10 @@ stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyC
 bcoPrimTyConName             = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName            = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName                = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
+floatX4PrimTyConName          = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon
+doubleX2PrimTyConName         = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon
+int32X4PrimTyConName          = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon
+int64X2PrimTyConName          = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon
 \end{code}
 
 %************************************************************************
@@ -241,7 +256,7 @@ funTyCon = mkFunTyCon funTyConName $
         -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
        -- But if we do that we get kind errors when saying
        --      instance Control.Arrow (->)
-       -- becuase the expected kind is (*->*->*).  The trouble is that the
+       -- because the expected kind is (*->*->*).  The trouble is that the
        -- expected/actual stuff in the unifier does not go contra-variant, whereas
        -- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
        -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
@@ -653,7 +668,7 @@ The type constructor Any of kind forall k. k -> k has these properties:
   * It is a *closed* type family, with no instances.  This means that
     if   ty :: '(k1, k2)  we add a given coercion
              g :: ty ~ (Fst ty, Snd ty)
-    If Any was a *data* type, then we'd get inconsistency becuase 'ty'
+    If Any was a *data* type, then we'd get inconsistency because 'ty'
     could be (Any '(k1,k2)) and then we'd have an equality with Any on
     one side and '(,) on the other
 
@@ -729,3 +744,31 @@ anyTyCon = mkSynTyCon anyTyConName kind [kKiVar]
 anyTypeOfKind :: Kind -> Type
 anyTypeOfKind kind = mkNakedTyConApp anyTyCon [kind]
 \end{code}
+
+%************************************************************************
+%*                                                                     *
+\subsection{SIMD vector type}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+floatX4PrimTy :: Type
+floatX4PrimTy = mkTyConTy floatX4PrimTyCon
+floatX4PrimTyCon :: TyCon
+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)
+
+doubleX2PrimTy :: Type
+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon
+doubleX2PrimTyCon :: TyCon
+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)
+
+int32X4PrimTy :: Type
+int32X4PrimTy = mkTyConTy int32X4PrimTyCon
+int32X4PrimTyCon :: TyCon
+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)
+
+int64X2PrimTy :: Type
+int64X2PrimTy = mkTyConTy int64X2PrimTyCon
+int64X2PrimTyCon :: TyCon
+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)
+\end{code}
index 6d551d9..a5b0fec 100644 (file)
@@ -47,6 +47,7 @@ defaults
    code_size        = { primOpCodeSizeDefault }
    strictness       = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity topDmd) topRes) }
    fixity           = Nothing
+   llvm_only        = False
 
 -- Currently, documentation is produced using latex, so contents of
 -- description fields should be legal latex. Descriptions can contain
@@ -2202,6 +2203,499 @@ primop  TraceMarkerOp "traceMarker#" GenPrimOp
 
 
 ------------------------------------------------------------------------
+section "Float SIMD Vectors" 
+       {Operations on SIMD vectors of 4 single-precision (32-bit)
+         floating-point numbers.}
+------------------------------------------------------------------------
+
+primtype FloatX4#
+   with llvm_only = True
+
+primop FloatToFloatX4Op "floatToFloatX4#" GenPrimOp     
+   Float# -> FloatX4#
+   with llvm_only = True
+
+primop FloatX4PackOp "packFloatX4#" GenPrimOp         
+   Float# -> Float# -> Float# -> Float# -> FloatX4#
+   with llvm_only = True
+
+primop FloatX4UnpackOp "unpackFloatX4#" GenPrimOp         
+   FloatX4# -> (# Float#, Float#, Float#, Float# #)
+   with llvm_only = True
+
+primop FloatX4InsertOp "insertFloatX4#" GenPrimOp     
+   FloatX4# -> Float# -> Int# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop FloatX4AddOp "plusFloatX4#" Dyadic            
+   FloatX4# -> FloatX4# -> FloatX4#
+   with commutable = True
+        llvm_only = True
+
+primop FloatX4SubOp "minusFloatX4#" Dyadic
+  FloatX4# -> FloatX4# -> FloatX4#
+   with llvm_only = True
+
+primop FloatX4MulOp "timesFloatX4#" Dyadic    
+   FloatX4# -> FloatX4# -> FloatX4#
+   with commutable = True
+        llvm_only = True
+
+primop FloatX4DivOp "divideFloatX4#" Dyadic  
+   FloatX4# -> FloatX4# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop FloatX4NegOp "negateFloatX4#" Monadic
+   FloatX4# -> FloatX4#
+   with llvm_only = True
+
+primop IndexByteArrayOp_FloatX4 "indexFloatX4Array#" GenPrimOp
+   ByteArray# -> Int# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadByteArrayOp_FloatX4 "readFloatX4Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, FloatX4# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop WriteByteArrayOp_FloatX4 "writeFloatX4Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexOffAddrOp_FloatX4 "indexFloatX4OffAddr#" GenPrimOp
+   Addr# -> Int# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadOffAddrOp_FloatX4 "readFloatX4OffAddr#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, FloatX4# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop  WriteOffAddrOp_FloatX4 "writeFloatX4OffAddr#" GenPrimOp
+   Addr# -> Int# -> FloatX4# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexByteArrayOp_FloatAsFloatX4 "indexFloatArrayAsFloatX4#" GenPrimOp
+   ByteArray# -> Int# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadByteArrayOp_FloatAsFloatX4 "readFloatArrayAsFloatX4#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, FloatX4# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop WriteByteArrayOp_FloatAsFloatX4 "writeFloatArrayAsFloatX4#" GenPrimOp
+   MutableByteArray# s -> Int# -> FloatX4# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexOffAddrOp_FloatAsFloatX4 "indexFloatOffAddrAsFloatX4#" GenPrimOp
+   Addr# -> Int# -> FloatX4#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadOffAddrOp_FloatAsFloatX4 "readFloatOffAddrAsFloatX4#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, FloatX4# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop  WriteOffAddrOp_FloatAsFloatX4 "writeFloatOffAddrAsFloatX4#" GenPrimOp
+   Addr# -> Int# -> FloatX4# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+------------------------------------------------------------------------
+section "Double SIMD Vectors" 
+       {Operations on SIMD vectors of 2 double-precision (64-bit)
+         floating-point numbers.}
+------------------------------------------------------------------------
+
+primtype DoubleX2#
+   with llvm_only = True
+
+primop DoubleToDoubleX2Op "doubleToDoubleX2#" GenPrimOp     
+   Double# -> DoubleX2#
+   with llvm_only = True
+
+primop DoubleX2InsertOp "insertDoubleX2#" GenPrimOp     
+   DoubleX2# -> Double# -> Int# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop DoubleX2PackOp "packDoubleX2#" GenPrimOp         
+   Double# -> Double# -> DoubleX2#
+   with llvm_only = True
+
+primop DoubleX2UnpackOp "unpackDoubleX2#" GenPrimOp         
+   DoubleX2# -> (# Double#, Double# #)
+   with llvm_only = True
+
+primop DoubleX2AddOp "plusDoubleX2#" Dyadic            
+   DoubleX2# -> DoubleX2# -> DoubleX2#
+   with commutable = True
+        llvm_only = True
+
+primop DoubleX2SubOp "minusDoubleX2#" Dyadic
+  DoubleX2# -> DoubleX2# -> DoubleX2#
+   with llvm_only = True
+
+primop DoubleX2MulOp "timesDoubleX2#" Dyadic    
+   DoubleX2# -> DoubleX2# -> DoubleX2#
+   with commutable = True
+        llvm_only = True
+
+primop DoubleX2DivOp "divideDoubleX2#" Dyadic  
+   DoubleX2# -> DoubleX2# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop DoubleX2NegOp "negateDoubleX2#" Monadic
+   DoubleX2# -> DoubleX2#
+   with llvm_only = True
+
+primop IndexByteArrayOp_DoubleX2 "indexDoubleX2Array#" GenPrimOp
+   ByteArray# -> Int# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadByteArrayOp_DoubleX2 "readDoubleX2Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, DoubleX2# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop WriteByteArrayOp_DoubleX2 "writeDoubleX2Array#" GenPrimOp
+   MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexOffAddrOp_DoubleX2 "indexDoubleX2OffAddr#" GenPrimOp
+   Addr# -> Int# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadOffAddrOp_DoubleX2 "readDoubleX2OffAddr#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, DoubleX2# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop  WriteOffAddrOp_DoubleX2 "writeDoubleX2OffAddr#" GenPrimOp
+   Addr# -> Int# -> DoubleX2# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexByteArrayOp_DoubleAsDoubleX2 "indexDoubleArrayAsDoubleX2#" GenPrimOp
+   ByteArray# -> Int# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadByteArrayOp_DoubleAsDoubleX2 "readDoubleArrayAsDoubleX2#" GenPrimOp
+   MutableByteArray# s -> Int# -> State# s -> (# State# s, DoubleX2# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop WriteByteArrayOp_DoubleAsDoubleX2 "writeDoubleArrayAsDoubleX2#" GenPrimOp
+   MutableByteArray# s -> Int# -> DoubleX2# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop IndexOffAddrOp_DoubleAsDoubleX2 "indexDoubleOffAddrAsDoubleX2#" GenPrimOp
+   Addr# -> Int# -> DoubleX2#
+   with can_fail = True
+        llvm_only = True
+
+primop ReadOffAddrOp_DoubleAsDoubleX2 "readDoubleOffAddrAsDoubleX2#" GenPrimOp
+   Addr# -> Int# -> State# s -> (# State# s, DoubleX2# #)
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+primop  WriteOffAddrOp_DoubleAsDoubleX2 "writeDoubleOffAddrAsDoubleX2#" GenPrimOp
+   Addr# -> Int# -> DoubleX2# -> State# s -> State# s
+   with has_side_effects = True
+        can_fail = True
+        llvm_only = True
+
+------------------------------------------------------------------------
+section "Int32 SIMD Vectors" 
+       {Operations on SIMD vectors of 4 32-bit signed integers.}
+------------------------------------------------------------------------
+
+primtype Int32X4#
+   with llvm_only = True
+
+primop Int32ToInt32X4Op "int32ToInt32X4#" GenPrimOp     
+   INT32 -> Int32X4#
+   with llvm_only = True
+
+primop Int32X4InsertOp "insertInt32X4#" GenPrimOp     
+   Int32X4# -> INT32 -> Int# -> Int32X4#
+   with can_fail = True
+        llvm_only = True
+
+primop Int32X4PackOp "packInt32X4#" GenPrimOp         
+   INT32 -> INT32 -> INT32 -> INT32 -> Int32X4#
+   with llvm_only = True
+
+primop Int32X4UnpackOp "unpackInt32X4#" GenPrimOp         
+&nb