Skip to content

GitLab

Commit aaff8766 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parents 05debbb4 09037d92
Hide whitespace changes
Inline Side-by-side
compiler/cmm/CmmMachOp.hs
View file @ aaff8766
......@@ -442,6 +442,7 @@ data CallishMachOp
| MO_S_QuotRem Width
| MO_U_QuotRem Width
| MO_U_QuotRem2 Width
| MO_Add2 Width
| MO_U_Mul2 Width
......
compiler/cmm/PprC.hs
View file @ aaff8766
......@@ -661,11 +661,12 @@ pprCallishMachOp_for_C mop
MO_Memmove -> ptext (sLit "memmove")
(MO_PopCnt w) -> ptext (sLit $ popCntLabel w)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_Touch -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_Touch -> unsupported
where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
++ " not supported!")
......
compiler/codeGen/CgPrimOp.hs
View file @ aaff8766
......@@ -468,6 +468,59 @@ emitPrimOp [res_q, res_r] WordQuotRemOp [arg_x, arg_y] _
CmmHinted arg_y NoHint]
CmmMayReturn
in stmtC stmt
emitPrimOp [res_q, res_r] WordQuotRem2Op [arg_x_high, arg_x_low, arg_y] _
= do let ty = cmmExprType arg_x_high
shl x i = CmmMachOp (MO_Shl wordWidth) [x, i]
shr x i = CmmMachOp (MO_U_Shr wordWidth) [x, i]
or x y = CmmMachOp (MO_Or wordWidth) [x, y]
ge x y = CmmMachOp (MO_U_Ge wordWidth) [x, y]
ne x y = CmmMachOp (MO_Ne wordWidth) [x, y]
minus x y = CmmMachOp (MO_Sub wordWidth) [x, y]
times x y = CmmMachOp (MO_Mul wordWidth) [x, y]
zero = lit 0
one = lit 1
negone = lit (fromIntegral (widthInBits wordWidth) - 1)
lit i = CmmLit (CmmInt i wordWidth)
f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode [CmmStmt]
f 0 acc high _ = return [CmmAssign (CmmLocal res_q) acc,
CmmAssign (CmmLocal res_r) high]
f i acc high low =
do roverflowedBit <- newLocalReg ty
rhigh' <- newLocalReg ty
rhigh'' <- newLocalReg ty
rlow' <- newLocalReg ty
risge <- newLocalReg ty
racc' <- newLocalReg ty
let high' = CmmReg (CmmLocal rhigh')
isge = CmmReg (CmmLocal risge)
overflowedBit = CmmReg (CmmLocal roverflowedBit)
let this = [CmmAssign (CmmLocal roverflowedBit)
(shr high negone),
CmmAssign (CmmLocal rhigh')
(or (shl high one) (shr low negone)),
CmmAssign (CmmLocal rlow')
(shl low one),
CmmAssign (CmmLocal risge)
(or (overflowedBit `ne` zero)
(high' `ge` arg_y)),
CmmAssign (CmmLocal rhigh'')
(high' `minus` (arg_y `times` isge)),
CmmAssign (CmmLocal racc')
(or (shl acc one) isge)]
rest <- f (i - 1) (CmmReg (CmmLocal racc'))
(CmmReg (CmmLocal rhigh''))
(CmmReg (CmmLocal rlow'))
return (this ++ rest)
genericImpl <- f (widthInBits wordWidth) zero arg_x_high arg_x_low
let stmt = CmmCall (CmmPrim (MO_U_QuotRem2 wordWidth) (Just genericImpl))
[CmmHinted res_q NoHint,
CmmHinted res_r NoHint]
[CmmHinted arg_x_high NoHint,
CmmHinted arg_x_low NoHint,
CmmHinted arg_y NoHint]
CmmMayReturn
stmtC stmt
emitPrimOp [res_h, res_l] WordAdd2Op [arg_x, arg_y] _
= do r1 <- newLocalReg (cmmExprType arg_x)
r2 <- newLocalReg (cmmExprType arg_x)
......
compiler/ghc.mk
View file @ aaff8766
......@@ -27,8 +27,6 @@ endef
# The 'echo' commands simply spit the values of various make variables
# into Config.hs, whence they can be compiled and used by GHC itself
compiler_CONFIG_HS = compiler/main/Config.hs
# This is just to avoid generating a warning when generating deps
# involving RtsFlags.h
compiler_stage1_MKDEPENDC_OPTS = -DMAKING_GHC_BUILD_SYSTEM_DEPENDENCIES
......
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
View file @ aaff8766
......@@ -473,12 +473,13 @@ cmmPrimOpFunctions env mop
(MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
where
intrinTy1 = (if getLlvmVer env >= 28
......
compiler/nativeGen/PPC/CodeGen.hs
View file @ aaff8766
......@@ -1145,12 +1145,13 @@ genCCall' gcp target dest_regs argsAndHints
MO_PopCnt w -> (fsLit $ popCntLabel w, False)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported")
......
compiler/nativeGen/SPARC/CodeGen.hs
View file @ aaff8766
......@@ -640,12 +640,13 @@ outOfLineMachOp_table mop
MO_PopCnt w -> fsLit $ popCntLabel w
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
where unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported here")
compiler/nativeGen/X86/CodeGen.hs
View file @ aaff8766
......@@ -1676,8 +1676,9 @@ genCCall32 target dest_regs args =
= panic $ "genCCall32.actuallyInlineFloatOp: bad number of arguments! ("
++ show (length args) ++ ")"
(CmmPrim (MO_S_QuotRem width) _, _) -> divOp True width dest_regs args
(CmmPrim (MO_U_QuotRem width) _, _) -> divOp False width dest_regs args
(CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args
(CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args
(CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args
(CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
case args of
[CmmHinted arg_x _, CmmHinted arg_y _] ->
......@@ -1712,8 +1713,18 @@ genCCall32 target dest_regs args =
_ -> genCCall32' target dest_regs args
where divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
[CmmHinted arg_x _, CmmHinted arg_y _]
where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
= divOp signed width results Nothing arg_x arg_y
divOp1 _ _ _ _
= panic "genCCall32: Wrong number of arguments for divOp1"
divOp2 signed width results [CmmHinted arg_x_high _,
CmmHinted arg_x_low _,
CmmHinted arg_y _]
= divOp signed width results (Just arg_x_high) arg_x_low arg_y
divOp2 _ _ _ _
= panic "genCCall64: Wrong number of arguments for divOp2"
divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
m_arg_x_high arg_x_low arg_y
= do let size = intSize width
reg_q = getRegisterReg True (CmmLocal res_q)
reg_r = getRegisterReg True (CmmLocal res_r)
......@@ -1722,15 +1733,20 @@ genCCall32 target dest_regs args =
instr | signed = IDIV
| otherwise = DIV
(y_reg, y_code) <- getRegOrMem arg_y
x_code <- getAnyReg arg_x
x_low_code <- getAnyReg arg_x_low
x_high_code <- case m_arg_x_high of
Just arg_x_high ->
getAnyReg arg_x_high
Nothing ->
return $ const $ unitOL widen
return $ y_code `appOL`
x_code rax `appOL`
toOL [widen,
instr size y_reg,
x_low_code rax `appOL`
x_high_code rdx `appOL`
toOL [instr size y_reg,
MOV size (OpReg rax) (OpReg reg_q),
MOV size (OpReg rdx) (OpReg reg_r)]
divOp _ _ _ _
= panic "genCCall32: Wrong number of arguments/results for divOp"
divOp _ _ _ _ _ _
= panic "genCCall32: Wrong number of results for divOp"
genCCall32' :: CmmCallTarget -- function to call
-> [HintedCmmFormal] -- where to put the result
......@@ -1896,8 +1912,9 @@ genCCall64 target dest_regs args =
-- we only cope with a single result for foreign calls
outOfLineCmmOp op (Just res) args
(CmmPrim (MO_S_QuotRem width) _, _) -> divOp True width dest_regs args
(CmmPrim (MO_U_QuotRem width) _, _) -> divOp False width dest_regs args
(CmmPrim (MO_S_QuotRem width) _, _) -> divOp1 True width dest_regs args
(CmmPrim (MO_U_QuotRem width) _, _) -> divOp1 False width dest_regs args
(CmmPrim (MO_U_QuotRem2 width) _, _) -> divOp2 False width dest_regs args
(CmmPrim (MO_Add2 width) _, [CmmHinted res_h _, CmmHinted res_l _]) ->
case args of
[CmmHinted arg_x _, CmmHinted arg_y _] ->
......@@ -1935,8 +1952,18 @@ genCCall64 target dest_regs args =
let platform = targetPlatform dflags
genCCall64' platform target dest_regs args
where divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
[CmmHinted arg_x _, CmmHinted arg_y _]
where divOp1 signed width results [CmmHinted arg_x _, CmmHinted arg_y _]
= divOp signed width results Nothing arg_x arg_y
divOp1 _ _ _ _
= panic "genCCall64: Wrong number of arguments for divOp1"
divOp2 signed width results [CmmHinted arg_x_high _,
CmmHinted arg_x_low _,
CmmHinted arg_y _]
= divOp signed width results (Just arg_x_high) arg_x_low arg_y
divOp2 _ _ _ _
= panic "genCCall64: Wrong number of arguments for divOp2"
divOp signed width [CmmHinted res_q _, CmmHinted res_r _]
m_arg_x_high arg_x_low arg_y
= do let size = intSize width
reg_q = getRegisterReg True (CmmLocal res_q)
reg_r = getRegisterReg True (CmmLocal res_r)
......@@ -1945,15 +1972,18 @@ genCCall64 target dest_regs args =
instr | signed = IDIV
| otherwise = DIV
(y_reg, y_code) <- getRegOrMem arg_y
x_code <- getAnyReg arg_x
x_low_code <- getAnyReg arg_x_low
x_high_code <- case m_arg_x_high of
Just arg_x_high -> getAnyReg arg_x_high
Nothing -> return $ const $ unitOL widen
return $ y_code `appOL`
x_code rax `appOL`
toOL [widen,
instr size y_reg,
x_low_code rax `appOL`
x_high_code rdx `appOL`
toOL [instr size y_reg,
MOV size (OpReg rax) (OpReg reg_q),
MOV size (OpReg rdx) (OpReg reg_r)]
divOp _ _ _ _
= panic "genCCall64: Wrong number of arguments/results for divOp"
divOp _ _ _ _ _ _
= panic "genCCall64: Wrong number of results for divOp"
genCCall64' :: Platform
-> CmmCallTarget -- function to call
......@@ -2225,12 +2255,13 @@ outOfLineCmmOp mop res args
MO_PopCnt _ -> fsLit "popcnt"
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ "not supported here")
......
compiler/prelude/primops.txt.pp
View file @ aaff8766
......@@ -269,6 +269,7 @@ primtype Word#
primop WordAddOp "plusWord#" Dyadic Word# -> Word# -> Word#
with commutable = True
-- Returns (# high, low #) (or equivalently, (# carry, low #))
primop WordAdd2Op "plusWord2#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with commutable = True
......@@ -278,6 +279,7 @@ primop WordSubOp "minusWord#" Dyadic Word# -> Word# -> Word#
primop WordMulOp "timesWord#" Dyadic Word# -> Word# -> Word#
with commutable = True
-- Returns (# high, low #)
primop WordMul2Op "timesWord2#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with commutable = True
......@@ -292,6 +294,12 @@ primop WordQuotRemOp "quotRemWord#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with can_fail = True
-- Takes high word of dividend, then low word of dividend, then divisor.
-- Requires that high word is not divisible by divisor.
primop WordQuotRem2Op "quotRemWord2#" GenPrimOp
Word# -> Word# -> Word# -> (# Word#, Word# #)
with can_fail = True
primop AndOp "and#" Dyadic Word# -> Word# -> Word#
with commutable = True
......
compiler/typecheck/FamInst.lhs
View file @ aaff8766
......@@ -24,12 +24,11 @@ import TyCon
import DynFlags
import Name
import Module
import SrcLoc
import Outputable
import UniqFM
import VarSet
import FastString
import Util( filterOut )
import Util( filterOut, sortWith )
import Maybes
import Control.Monad
import Data.Map (Map)
......@@ -308,15 +307,18 @@ checkForConflicts inst_envs fam_inst
conflictInstErr :: FamInst -> FamInst -> TcRn ()
conflictInstErr famInst conflictingFamInst
= addFamInstLoc famInst $
addErr (hang (ptext (sLit "Conflicting family instance declarations:"))
2 (pprFamInsts [famInst, conflictingFamInst]))
addFamInstLoc :: FamInst -> TcRn a -> TcRn a
addFamInstLoc famInst thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc famInst
= addFamInstsErr (ptext (sLit "Conflicting family instance declarations:"))
[famInst, conflictingFamInst]
addFamInstsErr :: SDoc -> [FamInst] -> TcRn ()
addFamInstsErr herald insts
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprFamInsts sorted))
where
sorted = sortWith getSrcLoc insts
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
tcGetFamInstEnvs :: TcM FamInstEnvs
-- Gets both the external-package inst-env
......
compiler/typecheck/Inst.lhs
View file @ aaff8766
......@@ -474,25 +474,28 @@ traceDFuns ispecs
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ispec ispecs
= addDictLoc ispec $
addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
2 (pprInstances (ispec:ispecs)))
= addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
(ispec : ispecs)
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ispec dup_ispec
= addDictLoc ispec $
addErr (hang (ptext (sLit "Duplicate instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
= addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
[ispec, dup_ispec]
overlappingInstErr :: ClsInst -> ClsInst -> TcRn ()
overlappingInstErr ispec dup_ispec
= addDictLoc ispec $
addErr (hang (ptext (sLit "Overlapping instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
addDictLoc :: ClsInst -> TcRn a -> TcRn a
addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc ispec
= addClsInstsErr (ptext (sLit "Overlapping instance declarations:"))
[ispec, dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprInstances sorted))
where
sorted = sortWith getSrcLoc ispecs
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
\end{code}
%************************************************************************
......
compiler/types/InstEnv.lhs
View file @ aaff8766
......@@ -34,7 +34,6 @@ import BasicTypes
import UniqFM
import Id
import FastString
import Data.Data ( Data, Typeable )
import Data.Maybe ( isJust, isNothing )
\end{code}
......
ghc/InteractiveUI.hs
View file @ aaff8766
......@@ -2837,14 +2837,16 @@ showException :: SomeException -> GHCi ()
showException se =
liftIO $ case fromException se of
-- omit the location for CmdLineError:
Just (CmdLineError s) -> putStrLn s
Just (CmdLineError s) -> putException s
-- ditto:
Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
Just other_ghc_ex -> print other_ghc_ex
Just ph@(PhaseFailed {}) -> putException (showGhcException ph "")
Just other_ghc_ex -> putException (show other_ghc_ex)
Nothing ->
case fromException se of
Just UserInterrupt -> putStrLn "Interrupted."
_ -> putStrLn ("*** Exception: " ++ show se)
Just UserInterrupt -> putException "Interrupted."
_ -> putException ("*** Exception: " ++ show se)
where
putException = hPutStrLn stderr
-----------------------------------------------------------------------------
......
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