Commit df176510 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents f37cf0d0 c99e675a
...@@ -169,6 +169,28 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do ...@@ -169,6 +169,28 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
lmTrue = mkIntLit i1 (-1) lmTrue = mkIntLit i1 (-1)
#endif #endif
-- 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
-- is strict about types.
genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do
let width = widthToLlvmInt w
dstTy = cmmToLlvmType $ localRegType dst
funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
CC_Ccc width FixedArgs (tysToParams [width]) Nothing
(env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
(env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
(env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t
(argsV', stmts4) <- castVars $ zip argsV [width]
(retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
([retV'], stmts5) <- castVars [(retV,dstTy)]
let s2 = Store retV' dstV
let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL`
s1 `appOL` stmts5 `snocOL` s2
return (env3, stmts, top1 ++ top2 ++ top3)
-- Handle memcpy function specifically since llvm's intrinsic version takes -- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters. -- some extra parameters.
genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
...@@ -436,6 +458,8 @@ cmmPrimOpFunctions env mop ...@@ -436,6 +458,8 @@ cmmPrimOpFunctions env mop
MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
(MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")" a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
where where
......
...@@ -51,12 +51,12 @@ moduleLayout = ...@@ -51,12 +51,12 @@ moduleLayout =
$+$ text "target triple = \"x86_64-linux-gnu\"" $+$ text "target triple = \"x86_64-linux-gnu\""
#endif #endif
-- #elif defined (arm_TARGET_ARCH) #elif defined (arm_TARGET_ARCH)
-- #if linux_TARGET_OS #if linux_TARGET_OS
-- text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\"" text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
-- $+$ text "target triple = \"arm-unknown-linux-gnueabi\"" $+$ text "target triple = \"arm-unknown-linux-gnueabi\""
-- #endif #endif
#else #else
-- FIX: Other targets -- FIX: Other targets
......
...@@ -1333,7 +1333,8 @@ runPhase LlvmLlc input_fn dflags ...@@ -1333,7 +1333,8 @@ runPhase LlvmLlc input_fn dflags
SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_fn, SysTools.FileOption "" input_fn,
SysTools.Option "-o", SysTools.FileOption "" output_fn] SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts) ++ map SysTools.Option lc_opts
++ map SysTools.Option fpOpts)
return (LlvmMangle, output_fn) return (LlvmMangle, output_fn)
where where
...@@ -1341,6 +1342,17 @@ runPhase LlvmLlc input_fn dflags ...@@ -1341,6 +1342,17 @@ runPhase LlvmLlc input_fn dflags
llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
then ["-O1", "-O2", "-O2"] then ["-O1", "-O2", "-O2"]
else ["-O1", "-O2", "-O3"] else ["-O1", "-O2", "-O3"]
-- On ARMv7 using LLVM, LLVM fails to allocate floating point registers
-- while compiling GHC source code. It's probably due to fact
-- that it does not enable VFP by default. Let's do this manually
-- here
fpOpts = case platformArch (targetPlatform dflags) of
ArchARM ARMv7 ext -> if (elem VFPv3 ext)
then ["-mattr=+v7,+vfp3"]
else if (elem VFPv3D16 ext)
then ["-mattr=+v7,+vfp3,+d16"]
else []
_ -> []
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- LlvmMangle phase -- LlvmMangle phase
...@@ -1465,8 +1477,8 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do ...@@ -1465,8 +1477,8 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do
elfSectionNote :: String elfSectionNote :: String
elfSectionNote = case platformArch (targetPlatform dflags) of elfSectionNote = case platformArch (targetPlatform dflags) of
ArchARM -> "%note" ArchARM _ _ -> "%note"
_ -> "@note" _ -> "@note"
-- The "link info" is a string representing the parameters of the -- The "link info" is a string representing the parameters of the
-- link. We save this information in the binary, and the next time we -- link. We save this information in the binary, and the next time we
......
...@@ -199,7 +199,7 @@ nativeCodeGen dflags h us cmms ...@@ -199,7 +199,7 @@ nativeCodeGen dflags h us cmms
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = id ,ncgMakeFarBranches = id
} }
ArchARM -> ArchARM _ _ ->
panic "nativeCodeGen: No NCG for ARM" panic "nativeCodeGen: No NCG for ARM"
ArchPPC_64 -> ArchPPC_64 ->
panic "nativeCodeGen: No NCG for PPC 64" panic "nativeCodeGen: No NCG for PPC 64"
......
...@@ -112,7 +112,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl ...@@ -112,7 +112,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl
ArchPPC -> 16 ArchPPC -> 16
ArchSPARC -> 14 ArchSPARC -> 14
ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM" ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown") ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER
(virtualRegSqueeze RcInteger) (virtualRegSqueeze RcInteger)
...@@ -132,7 +132,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus ...@@ -132,7 +132,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus
ArchPPC -> 0 ArchPPC -> 0
ArchSPARC -> 22 ArchSPARC -> 22
ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM" ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown") ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT
(virtualRegSqueeze RcFloat) (virtualRegSqueeze RcFloat)
...@@ -152,7 +152,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu ...@@ -152,7 +152,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu
ArchPPC -> 26 ArchPPC -> 26
ArchSPARC -> 11 ArchSPARC -> 11
ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM" ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown") ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE
(virtualRegSqueeze RcDouble) (virtualRegSqueeze RcDouble)
...@@ -172,7 +172,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex ...@@ -172,7 +172,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex
ArchPPC -> 0 ArchPPC -> 0
ArchSPARC -> 0 ArchSPARC -> 0
ArchPPC_64 -> panic "trivColorable ArchPPC_64" ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM" ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown") ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE
(virtualRegSqueeze RcDoubleSSE) (virtualRegSqueeze RcDoubleSSE)
......
...@@ -65,7 +65,7 @@ maxSpillSlots platform ...@@ -65,7 +65,7 @@ maxSpillSlots platform
ArchX86_64 -> X86.Instr.maxSpillSlots ArchX86_64 -> X86.Instr.maxSpillSlots
ArchPPC -> PPC.Instr.maxSpillSlots ArchPPC -> PPC.Instr.maxSpillSlots
ArchSPARC -> SPARC.Instr.maxSpillSlots ArchSPARC -> SPARC.Instr.maxSpillSlots
ArchARM -> panic "maxSpillSlots ArchARM" ArchARM _ _ -> panic "maxSpillSlots ArchARM"
ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64"
ArchUnknown -> panic "maxSpillSlots ArchUnknown" ArchUnknown -> panic "maxSpillSlots ArchUnknown"
...@@ -184,7 +184,7 @@ linearRegAlloc dflags first_id block_live sccs ...@@ -184,7 +184,7 @@ linearRegAlloc dflags first_id block_live sccs
ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs
ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs
ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs
ArchARM -> panic "linearRegAlloc ArchARM" ArchARM _ _ -> panic "linearRegAlloc ArchARM"
ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64"
ArchUnknown -> panic "linearRegAlloc ArchUnknown" ArchUnknown -> panic "linearRegAlloc ArchUnknown"
......
...@@ -48,7 +48,7 @@ targetVirtualRegSqueeze platform ...@@ -48,7 +48,7 @@ targetVirtualRegSqueeze platform
ArchPPC -> PPC.virtualRegSqueeze ArchPPC -> PPC.virtualRegSqueeze
ArchSPARC -> SPARC.virtualRegSqueeze ArchSPARC -> SPARC.virtualRegSqueeze
ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64"
ArchARM -> panic "targetVirtualRegSqueeze ArchARM" ArchARM _ _ -> panic "targetVirtualRegSqueeze ArchARM"
ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown"
targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt
...@@ -59,7 +59,7 @@ targetRealRegSqueeze platform ...@@ -59,7 +59,7 @@ targetRealRegSqueeze platform
ArchPPC -> PPC.realRegSqueeze ArchPPC -> PPC.realRegSqueeze
ArchSPARC -> SPARC.realRegSqueeze ArchSPARC -> SPARC.realRegSqueeze
ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64"
ArchARM -> panic "targetRealRegSqueeze ArchARM" ArchARM _ _ -> panic "targetRealRegSqueeze ArchARM"
ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown"
targetClassOfRealReg :: Platform -> RealReg -> RegClass targetClassOfRealReg :: Platform -> RealReg -> RegClass
...@@ -70,7 +70,7 @@ targetClassOfRealReg platform ...@@ -70,7 +70,7 @@ targetClassOfRealReg platform
ArchPPC -> PPC.classOfRealReg ArchPPC -> PPC.classOfRealReg
ArchSPARC -> SPARC.classOfRealReg ArchSPARC -> SPARC.classOfRealReg
ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64"
ArchARM -> panic "targetClassOfRealReg ArchARM" ArchARM _ _ -> panic "targetClassOfRealReg ArchARM"
ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" ArchUnknown -> panic "targetClassOfRealReg ArchUnknown"
-- TODO: This should look at targetPlatform too -- TODO: This should look at targetPlatform too
...@@ -85,7 +85,7 @@ targetMkVirtualReg platform ...@@ -85,7 +85,7 @@ targetMkVirtualReg platform
ArchPPC -> PPC.mkVirtualReg ArchPPC -> PPC.mkVirtualReg
ArchSPARC -> SPARC.mkVirtualReg ArchSPARC -> SPARC.mkVirtualReg
ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64"
ArchARM -> panic "targetMkVirtualReg ArchARM" ArchARM _ _ -> panic "targetMkVirtualReg ArchARM"
ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" ArchUnknown -> panic "targetMkVirtualReg ArchUnknown"
targetRegDotColor :: Platform -> RealReg -> SDoc targetRegDotColor :: Platform -> RealReg -> SDoc
...@@ -96,7 +96,7 @@ targetRegDotColor platform ...@@ -96,7 +96,7 @@ targetRegDotColor platform
ArchPPC -> PPC.regDotColor ArchPPC -> PPC.regDotColor
ArchSPARC -> SPARC.regDotColor ArchSPARC -> SPARC.regDotColor
ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64"
ArchARM -> panic "targetRegDotColor ArchARM" ArchARM _ _ -> panic "targetRegDotColor ArchARM"
ArchUnknown -> panic "targetRegDotColor ArchUnknown" ArchUnknown -> panic "targetRegDotColor ArchUnknown"
......
...@@ -58,7 +58,7 @@ normalRegColors platform ...@@ -58,7 +58,7 @@ normalRegColors platform
ArchPPC -> panic "X86 normalRegColors ArchPPC" ArchPPC -> panic "X86 normalRegColors ArchPPC"
ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64" ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64"
ArchSPARC -> panic "X86 normalRegColors ArchSPARC" ArchSPARC -> panic "X86 normalRegColors ArchSPARC"
ArchARM -> panic "X86 normalRegColors ArchARM" ArchARM _ _ -> panic "X86 normalRegColors ArchARM"
ArchUnknown -> panic "X86 normalRegColors ArchUnknown" ArchUnknown -> panic "X86 normalRegColors ArchUnknown"
fpRegColors :: [(Reg,String)] fpRegColors :: [(Reg,String)]
......
...@@ -639,11 +639,18 @@ rnHsVectDecl (HsVect var Nothing) ...@@ -639,11 +639,18 @@ rnHsVectDecl (HsVect var Nothing)
= do { var' <- lookupLocatedTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; return (HsVect var' Nothing, unitFV (unLoc var')) ; return (HsVect var' Nothing, unitFV (unLoc var'))
} }
rnHsVectDecl (HsVect var (Just rhs)) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
-- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
rnHsVectDecl (HsVect var (Just rhs@(L _ (HsVar _))))
= do { var' <- lookupLocatedTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; (rhs', fv_rhs) <- rnLExpr rhs ; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
} }
rnHsVectDecl (HsVect _var (Just _rhs))
= failWith $ vcat
[ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
, ptext (sLit "must be an identifier")
]
rnHsVectDecl (HsNoVect var) rnHsVectDecl (HsNoVect var)
= do { var' <- lookupLocatedTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; return (HsNoVect var', unitFV (unLoc var')) ; return (HsNoVect var', unitFV (unLoc var'))
...@@ -658,7 +665,7 @@ rnHsVectDecl (HsVectTypeIn tycon (Just ty)) ...@@ -658,7 +665,7 @@ rnHsVectDecl (HsVectTypeIn tycon (Just ty))
; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon') ; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon')
} }
where where
vect_doc = text "In the VECTORISE pragma for type constructor" <+> quotes (ppr tycon) vect_doc = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
rnHsVectDecl (HsVectTypeOut _ _) rnHsVectDecl (HsVectTypeOut _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
\end{code} \end{code}
......
...@@ -641,19 +641,26 @@ tcVectDecls decls ...@@ -641,19 +641,26 @@ tcVectDecls decls
-------------- --------------
tcVect :: VectDecl Name -> TcM (VectDecl TcId) tcVect :: VectDecl Name -> TcM (VectDecl TcId)
-- We can't typecheck the expression of a vectorisation declaration against the vectorised type -- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
-- of the original definition as this requires internals of the vectoriser not available during -- type of the original definition as this requires internals of the vectoriser not available
-- type checking. Instead, we infer the type of the expression and leave it to the vectoriser -- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
-- to check the compatibility of the Core types. -- identifier (this is checked in 'rnHsVectDecl').
tcVect (HsVect name Nothing) tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $ = addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name do { id <- wrapLocM tcLookupId name
; return $ HsVect id Nothing ; return $ HsVect id Nothing
} }
tcVect (HsVect name@(L loc _) (Just rhs)) tcVect (HsVect lname@(L loc name) (Just rhs))
= addErrCtxt (vectCtxt name) $ = addErrCtxt (vectCtxt lname) $
do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined do { id <- tcLookupId name
; let L rhs_loc (HsVar rhs_var_name) = rhs
; rhs_id <- tcLookupId rhs_var_name
; let typedId = setIdType id (idType rhs_id)
; return $ HsVect (L loc typedId) (Just $ L rhs_loc (HsVar rhs_id))
}
{- OLD CODE:
-- turn the vectorisation declaration into a single non-recursive binding -- turn the vectorisation declaration into a single non-recursive binding
; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs] ; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
sigFun = const Nothing sigFun = const Nothing
...@@ -661,7 +668,7 @@ tcVect (HsVect name@(L loc _) (Just rhs)) ...@@ -661,7 +668,7 @@ tcVect (HsVect name@(L loc _) (Just rhs))
-- perform type inference (including generalisation) -- perform type inference (including generalisation)
; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind] ; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id') ; traceTc "tcVect inferred type" $ ppr (varType id')
; traceTc "tcVect bindings" $ ppr binds ; traceTc "tcVect bindings" $ ppr binds
...@@ -678,6 +685,7 @@ tcVect (HsVect name@(L loc _) (Just rhs)) ...@@ -678,6 +685,7 @@ tcVect (HsVect name@(L loc _) (Just rhs))
-- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
; return $ HsVect (L loc id') (Just rhsWrapped) ; return $ HsVect (L loc id') (Just rhsWrapped)
} }
-}
tcVect (HsNoVect name) tcVect (HsNoVect name)
= addErrCtxt (vectCtxt name) $ = addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name do { id <- wrapLocM tcLookupId name
......
...@@ -7,6 +7,8 @@ module Platform ( ...@@ -7,6 +7,8 @@ module Platform (
Platform(..), Platform(..),
Arch(..), Arch(..),
OS(..), OS(..),
ArmISA(..),
ArmISAExt(..),
defaultTargetPlatform, defaultTargetPlatform,
target32Bit, target32Bit,
...@@ -40,6 +42,8 @@ data Arch ...@@ -40,6 +42,8 @@ data Arch
| ArchPPC_64 | ArchPPC_64
| ArchSPARC | ArchSPARC
| ArchARM | ArchARM
{ armISA :: ArmISA
, armISAExt :: [ArmISAExt] }
deriving (Show, Eq) deriving (Show, Eq)
...@@ -55,6 +59,22 @@ data OS ...@@ -55,6 +59,22 @@ data OS
| OSOpenBSD | OSOpenBSD
deriving (Show, Eq) deriving (Show, Eq)
-- | ARM Instruction Set Architecture and Extensions
--
data ArmISA
= ARMv5
| ARMv6
| ARMv7
deriving (Show, Eq)
data ArmISAExt
= VFPv2
| VFPv3
| VFPv3D16
| NEON
| IWMMX2
deriving (Show, Eq)
target32Bit :: Platform -> Bool target32Bit :: Platform -> Bool
target32Bit p = case platformArch p of target32Bit p = case platformArch p of
...@@ -64,7 +84,7 @@ target32Bit p = case platformArch p of ...@@ -64,7 +84,7 @@ target32Bit p = case platformArch p of
ArchPPC -> True ArchPPC -> True
ArchPPC_64 -> False ArchPPC_64 -> False
ArchSPARC -> True ArchSPARC -> True
ArchARM -> True ArchARM _ _ -> True
-- | This predicates tells us whether the OS supports ELF-like shared libraries. -- | This predicates tells us whether the OS supports ELF-like shared libraries.
...@@ -98,7 +118,7 @@ defaultTargetArch = ArchPPC_64 ...@@ -98,7 +118,7 @@ defaultTargetArch = ArchPPC_64
#elif sparc_TARGET_ARCH #elif sparc_TARGET_ARCH
defaultTargetArch = ArchSPARC defaultTargetArch = ArchSPARC
#elif arm_TARGET_ARCH #elif arm_TARGET_ARCH
defaultTargetArch = ArchARM defaultTargetArch = ArchARM defaultTargetArmISA defaultTargetArmISAExt
#else #else
defaultTargetArch = ArchUnknown defaultTargetArch = ArchUnknown
#endif #endif
...@@ -124,3 +144,22 @@ defaultTargetOS = OSOpenBSD ...@@ -124,3 +144,22 @@ defaultTargetOS = OSOpenBSD
defaultTargetOS = OSUnknown defaultTargetOS = OSUnknown
#endif #endif
#if arm_TARGET_ARCH
defaultTargetArmISA :: ArmISA
#if defined(arm_HOST_ARCH_PRE_ARMv6)
defaultTargetArmISA = ARMv5
#elif defined(arm_HOST_ARCH_PRE_ARMv7)
defaultTargetArmISA = ARMv6
#else
defaultTargetArmISA = ARMv7
#endif
defaultTargetArmISAExt :: [ArmISAExt]
#if defined(arm_TARGET_ARCH) && !defined(arm_HOST_ARCH_PRE_ARMv7)
/* wild guess really, in case of ARMv7 we assume both VFPv3 and NEON presented
however this is not true for SoCs like NVidia Tegra2 and Marvell Dove */
defaultTargetArmISAExt = [VFPv3, NEON]
#else
defaultTargetArmISAExt = []
#endif
#endif /* arm_TARGET_ARCH */
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment