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
lmTrue = mkIntLit i1 (-1)
#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
-- some extra parameters.
genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
......@@ -436,6 +458,8 @@ cmmPrimOpFunctions env mop
MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
(MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")"
where
......
......@@ -51,12 +51,12 @@ moduleLayout =
$+$ text "target triple = \"x86_64-linux-gnu\""
#endif
-- #elif defined (arm_TARGET_ARCH)
#elif defined (arm_TARGET_ARCH)
-- #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 triple = \"arm-unknown-linux-gnueabi\""
-- #endif
#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 triple = \"arm-unknown-linux-gnueabi\""
#endif
#else
-- FIX: Other targets
......
......@@ -1333,7 +1333,8 @@ runPhase LlvmLlc input_fn dflags
SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_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)
where
......@@ -1341,6 +1342,17 @@ runPhase LlvmLlc input_fn dflags
llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin
then ["-O1", "-O2", "-O2"]
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
......@@ -1465,8 +1477,8 @@ mkExtraObjToLinkIntoBinary dflags dep_packages = do
elfSectionNote :: String
elfSectionNote = case platformArch (targetPlatform dflags) of
ArchARM -> "%note"
_ -> "@note"
ArchARM _ _ -> "%note"
_ -> "@note"
-- The "link info" is a string representing the parameters of the
-- link. We save this information in the binary, and the next time we
......
......@@ -199,7 +199,7 @@ nativeCodeGen dflags h us cmms
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = id
}
ArchARM ->
ArchARM _ _ ->
panic "nativeCodeGen: No NCG for ARM"
ArchPPC_64 ->
panic "nativeCodeGen: No NCG for PPC 64"
......
......@@ -112,7 +112,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts excl
ArchPPC -> 16
ArchSPARC -> 14
ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM"
ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER
(virtualRegSqueeze RcInteger)
......@@ -132,7 +132,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclus
ArchPPC -> 0
ArchSPARC -> 22
ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM"
ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT
(virtualRegSqueeze RcFloat)
......@@ -152,7 +152,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclu
ArchPPC -> 26
ArchSPARC -> 11
ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM"
ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE
(virtualRegSqueeze RcDouble)
......@@ -172,7 +172,7 @@ trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts ex
ArchPPC -> 0
ArchSPARC -> 0
ArchPPC_64 -> panic "trivColorable ArchPPC_64"
ArchARM -> panic "trivColorable ArchARM"
ArchARM _ _ -> panic "trivColorable ArchARM"
ArchUnknown -> panic "trivColorable ArchUnknown")
, count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE
(virtualRegSqueeze RcDoubleSSE)
......
......@@ -65,7 +65,7 @@ maxSpillSlots platform
ArchX86_64 -> X86.Instr.maxSpillSlots
ArchPPC -> PPC.Instr.maxSpillSlots
ArchSPARC -> SPARC.Instr.maxSpillSlots
ArchARM -> panic "maxSpillSlots ArchARM"
ArchARM _ _ -> panic "maxSpillSlots ArchARM"
ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64"
ArchUnknown -> panic "maxSpillSlots ArchUnknown"
......@@ -184,7 +184,7 @@ linearRegAlloc dflags 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
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"
ArchUnknown -> panic "linearRegAlloc ArchUnknown"
......
......@@ -48,7 +48,7 @@ targetVirtualRegSqueeze platform
ArchPPC -> PPC.virtualRegSqueeze
ArchSPARC -> SPARC.virtualRegSqueeze
ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64"
ArchARM -> panic "targetVirtualRegSqueeze ArchARM"
ArchARM _ _ -> panic "targetVirtualRegSqueeze ArchARM"
ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown"
targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt
......@@ -59,7 +59,7 @@ targetRealRegSqueeze platform
ArchPPC -> PPC.realRegSqueeze
ArchSPARC -> SPARC.realRegSqueeze
ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64"
ArchARM -> panic "targetRealRegSqueeze ArchARM"
ArchARM _ _ -> panic "targetRealRegSqueeze ArchARM"
ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown"
targetClassOfRealReg :: Platform -> RealReg -> RegClass
......@@ -70,7 +70,7 @@ targetClassOfRealReg platform
ArchPPC -> PPC.classOfRealReg
ArchSPARC -> SPARC.classOfRealReg
ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64"
ArchARM -> panic "targetClassOfRealReg ArchARM"
ArchARM _ _ -> panic "targetClassOfRealReg ArchARM"
ArchUnknown -> panic "targetClassOfRealReg ArchUnknown"
-- TODO: This should look at targetPlatform too
......@@ -85,7 +85,7 @@ targetMkVirtualReg platform
ArchPPC -> PPC.mkVirtualReg
ArchSPARC -> SPARC.mkVirtualReg
ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64"
ArchARM -> panic "targetMkVirtualReg ArchARM"
ArchARM _ _ -> panic "targetMkVirtualReg ArchARM"
ArchUnknown -> panic "targetMkVirtualReg ArchUnknown"
targetRegDotColor :: Platform -> RealReg -> SDoc
......@@ -96,7 +96,7 @@ targetRegDotColor platform
ArchPPC -> PPC.regDotColor
ArchSPARC -> SPARC.regDotColor
ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64"
ArchARM -> panic "targetRegDotColor ArchARM"
ArchARM _ _ -> panic "targetRegDotColor ArchARM"
ArchUnknown -> panic "targetRegDotColor ArchUnknown"
......
......@@ -58,7 +58,7 @@ normalRegColors platform
ArchPPC -> panic "X86 normalRegColors ArchPPC"
ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64"
ArchSPARC -> panic "X86 normalRegColors ArchSPARC"
ArchARM -> panic "X86 normalRegColors ArchARM"
ArchARM _ _ -> panic "X86 normalRegColors ArchARM"
ArchUnknown -> panic "X86 normalRegColors ArchUnknown"
fpRegColors :: [(Reg,String)]
......
......@@ -639,11 +639,18 @@ rnHsVectDecl (HsVect var Nothing)
= do { var' <- lookupLocatedTopBndrRn 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
; (rhs', fv_rhs) <- rnLExpr rhs
; 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)
= do { var' <- lookupLocatedTopBndrRn var
; return (HsNoVect var', unitFV (unLoc var'))
......@@ -658,7 +665,7 @@ rnHsVectDecl (HsVectTypeIn tycon (Just ty))
; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon')
}
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 _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
\end{code}
......
......@@ -641,19 +641,26 @@ tcVectDecls decls
--------------
tcVect :: VectDecl Name -> TcM (VectDecl TcId)
-- We can't typecheck the expression of a vectorisation declaration against the vectorised type
-- of the original definition as this requires internals of the vectoriser not available during
-- type checking. Instead, we infer the type of the expression and leave it to the vectoriser
-- to check the compatibility of the Core types.
-- FIXME: We can't typecheck the expression of a vectorisation declaration against the vectorised
-- type of the original definition as this requires internals of the vectoriser not available
-- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
-- identifier (this is checked in 'rnHsVectDecl').
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
; return $ HsVect id Nothing
}
tcVect (HsVect name@(L loc _) (Just rhs))
= addErrCtxt (vectCtxt name) $
do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined
tcVect (HsVect lname@(L loc name) (Just rhs))
= addErrCtxt (vectCtxt lname) $
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
; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
sigFun = const Nothing
......@@ -661,7 +668,7 @@ tcVect (HsVect name@(L loc _) (Just rhs))
-- perform type inference (including generalisation)
; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
; traceTc "tcVect bindings" $ ppr binds
......@@ -678,6 +685,7 @@ tcVect (HsVect name@(L loc _) (Just rhs))
-- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls
; return $ HsVect (L loc id') (Just rhsWrapped)
}
-}
tcVect (HsNoVect name)
= addErrCtxt (vectCtxt name) $
do { id <- wrapLocM tcLookupId name
......
......@@ -7,6 +7,8 @@ module Platform (
Platform(..),
Arch(..),
OS(..),
ArmISA(..),
ArmISAExt(..),
defaultTargetPlatform,
target32Bit,
......@@ -40,6 +42,8 @@ data Arch
| ArchPPC_64
| ArchSPARC
| ArchARM
{ armISA :: ArmISA
, armISAExt :: [ArmISAExt] }
deriving (Show, Eq)
......@@ -55,6 +59,22 @@ data OS
| OSOpenBSD
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 p = case platformArch p of
......@@ -64,7 +84,7 @@ target32Bit p = case platformArch p of
ArchPPC -> True
ArchPPC_64 -> False
ArchSPARC -> True
ArchARM -> True
ArchARM _ _ -> True
-- | This predicates tells us whether the OS supports ELF-like shared libraries.
......@@ -98,7 +118,7 @@ defaultTargetArch = ArchPPC_64
#elif sparc_TARGET_ARCH
defaultTargetArch = ArchSPARC
#elif arm_TARGET_ARCH
defaultTargetArch = ArchARM
defaultTargetArch = ArchARM defaultTargetArmISA defaultTargetArmISAExt
#else
defaultTargetArch = ArchUnknown
#endif
......@@ -124,3 +144,22 @@ defaultTargetOS = OSOpenBSD
defaultTargetOS = OSUnknown
#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