diff options
Diffstat (limited to 'compiler')
78 files changed, 1920 insertions, 1442 deletions
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 42aaabc305..1c09599156 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -105,8 +105,10 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] CmmSwitch arg ids -> [Old.CmmSwitch arg ids] - CmmCall e _ _ _ _ -> [Old.CmmJump e] + -- ToDo: STG Live + CmmCall e _ _ _ _ -> [Old.CmmJump e Nothing] CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of Old.BasicBlock _ stmts -> stmts where Just block = mapLookup bid $ toBlockMap g + diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index a99e5a50a8..bed3b18b8e 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -143,7 +143,7 @@ lintCmmStmt platform labels = lint then return () else cmmLintErr (text "switch scrutinee is not a word: " <> pprPlatform platform e <> text " :: " <> ppr erep) - lint (CmmJump e) = lintCmmExpr platform e >> return () + lint (CmmJump e _) = lintCmmExpr platform e >> return () lint (CmmReturn) = return () lint (CmmBranch id) = checkTarget id checkTarget id = if setMember id labels then return () diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index 84f106980e..ae715a9eb7 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -65,7 +65,7 @@ cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = stmt m (CmmBranch b) = b:m stmt m (CmmCondBranch e b) = b:(expr m e) stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e - stmt m (CmmJump e) = expr m e + stmt m (CmmJump e _) = expr m e stmt m (CmmReturn) = m actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as -- We have to do a deep fold into CmmExpr because @@ -273,7 +273,7 @@ inlineStmt u a (CmmCall target regs es ret) es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ] inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d -inlineStmt u a (CmmJump e) = CmmJump (inlineExpr u a e) +inlineStmt u a (CmmJump e live) = CmmJump (inlineExpr u a e) live inlineStmt _ _ other_stmt = other_stmt inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr @@ -669,7 +669,7 @@ cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] - do_stmt (CmmJump (CmmLit (CmmLabel lbl))) | lbl == jump_lbl + do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl = CmmBranch top_id do_stmt stmt = stmt diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index f20a05f40f..029c3323db 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -411,8 +411,8 @@ stmt :: { ExtCode } { do as <- sequence $5; doSwitch $2 $3 as $6 } | 'goto' NAME ';' { do l <- lookupLabel $2; stmtEC (CmmBranch l) } - | 'jump' expr ';' - { do e <- $2; stmtEC (CmmJump e) } + | 'jump' expr vols ';' + { do e <- $2; stmtEC (CmmJump e $3) } | 'return' ';' { stmtEC CmmReturn } | 'if' bool_expr 'goto' NAME @@ -940,12 +940,12 @@ doStore rep addr_code val_code emitRetUT :: [(CgRep,CmmExpr)] -> Code emitRetUT args = do tickyUnboxedTupleReturn (length args) -- TICK - (sp, stmts) <- pushUnboxedTuple 0 args + (sp, stmts, live) <- pushUnboxedTuple 0 args emitSimultaneously stmts -- NB. the args might overlap with the stack slots -- or regs that we assign to, so better use -- simultaneous assignments here (#3546) when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp))) - stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) + stmtC $ CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) bWord)) (Just live) -- ----------------------------------------------------------------------------- -- If-then-else and boolean expressions diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs index 98e6db627f..7b5917d3bf 100644 --- a/compiler/cmm/OldCmm.hs +++ b/compiler/cmm/OldCmm.hs @@ -146,32 +146,46 @@ data CmmStmt = CmmNop | CmmComment FastString - | CmmAssign CmmReg CmmExpr -- Assign to register + | CmmAssign CmmReg CmmExpr -- Assign to register - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. + | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. - | CmmCall -- A call (foreign, native or primitive), with - CmmCallTarget - [HintedCmmFormal] -- zero or more results - [HintedCmmActual] -- zero or more arguments - CmmReturnInfo - -- Some care is necessary when handling the arguments of these, see - -- [Register parameter passing] and the hack in cmm/CmmOpt.hs + | CmmCall -- A call (foreign, native or primitive), with + CmmCallTarget + [HintedCmmFormal] -- zero or more results + [HintedCmmActual] -- zero or more arguments + CmmReturnInfo + -- Some care is necessary when handling the arguments of these, see + -- [Register parameter passing] and the hack in cmm/CmmOpt.hs | CmmBranch BlockId -- branch to another BB in this fn | CmmCondBranch CmmExpr BlockId -- conditional branch - | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch - -- The scrutinee is zero-based; - -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when there's a Nothing - - | CmmJump CmmExpr -- Jump to another C-- function, - - | CmmReturn -- Return from a native C-- function, + | CmmSwitch -- Table branch + CmmExpr -- The scrutinee is zero-based; + [Maybe BlockId] -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when + -- there's a Nothing + + | CmmJump -- Jump to another C-- function, + CmmExpr -- Target + (Maybe [GlobalReg]) -- Live registers at call site; + -- Nothing -> no information, assume + -- all live + -- Just .. -> info on liveness, [] + -- means no live registers + -- This isn't all 'live' registers, just + -- the argument STG registers that are live + -- AND also possibly mapped to machine + -- registers. (So Sp, Hp, HpLim... ect + -- are never included here as they are + -- always live, only R2.., D1.. are + -- on this list) + + | CmmReturn -- Return from a native C-- function, data CmmHinted a = CmmHinted { @@ -201,7 +215,7 @@ instance UserOfLocalRegs CmmStmt where stmt (CmmBranch _) = id stmt (CmmCondBranch e _) = gen e stmt (CmmSwitch e _) = gen e - stmt (CmmJump e) = gen e + stmt (CmmJump e _) = gen e stmt (CmmReturn) = id gen :: UserOfLocalRegs a => a -> b -> b diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs index 44692d45ac..4b1da0b242 100644 --- a/compiler/cmm/OldPprCmm.hs +++ b/compiler/cmm/OldPprCmm.hs @@ -32,12 +32,11 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- -module OldPprCmm - ( pprStmt - , module PprCmmDecl - , module PprCmmExpr - ) -where +module OldPprCmm ( + pprStmt, + module PprCmmDecl, + module PprCmmExpr + ) where import BlockId import CLabel @@ -46,7 +45,6 @@ import OldCmm import PprCmmDecl import PprCmmExpr - import BasicTypes import ForeignCall import Outputable @@ -109,7 +107,7 @@ pprStmt platform stmt = case stmt of -- ; CmmNop -> semi - -- // text + -- // text CmmComment s -> text "//" <+> ftext s -- reg = expr; @@ -153,7 +151,7 @@ pprStmt platform stmt = case stmt of CmmBranch ident -> genBranch ident CmmCondBranch expr ident -> genCondBranch platform expr ident - CmmJump expr -> genJump platform expr + CmmJump expr live -> genJump platform expr live CmmReturn -> genReturn platform CmmSwitch arg ids -> genSwitch platform arg ids @@ -176,7 +174,6 @@ pprUpdateFrame platform (UpdateFrame expr args) = , space , parens ( commafy $ map (pprPlatform platform) args ) ] - -- -------------------------------------------------------------------------- -- goto local label. [1], section 6.6 -- @@ -203,17 +200,17 @@ genCondBranch platform expr ident = -- -- jump foo(a, b, c); -- -genJump :: Platform -> CmmExpr -> SDoc -genJump platform expr = +genJump :: Platform -> CmmExpr -> Maybe [GlobalReg] -> SDoc +genJump platform expr live = hcat [ ptext (sLit "jump") , space , if isTrivialCmmExpr expr then pprExpr platform expr else case expr of CmmLoad (CmmReg _) _ -> pprExpr platform expr - _ -> parens (pprExpr platform expr) - , semi ] - + _ -> parens (pprExpr platform expr) + , semi <+> ptext (sLit "// ") + , maybe empty ppr live] -- -------------------------------------------------------------------------- -- Return from a function. [1], Section 6.8.2 of version 1.128 @@ -264,3 +261,4 @@ genSwitch platform expr maybe_ids commafy :: [SDoc] -> SDoc commafy xs = fsep $ punctuate comma xs + diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index 330d09082b..658e3ca5d8 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -248,7 +248,7 @@ pprStmt platform stmt = case stmt of CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch platform expr ident - CmmJump lbl -> mkJMP_(pprExpr platform lbl) <> semi + CmmJump lbl _ -> mkJMP_(pprExpr platform lbl) <> semi CmmSwitch arg ids -> pprSwitch platform arg ids pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc @@ -930,7 +930,7 @@ te_Stmt (CmmCall _ rs es _) = mapM_ (te_temp.hintlessCmm) rs >> mapM_ (te_Expr.hintlessCmm) es te_Stmt (CmmCondBranch e _) = te_Expr e te_Stmt (CmmSwitch e _) = te_Expr e -te_Stmt (CmmJump e) = te_Expr e +te_Stmt (CmmJump e _) = te_Expr e te_Stmt _ = return () te_Expr :: CmmExpr -> TE () diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 8e599c3fb5..d6537c27e5 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -362,6 +362,7 @@ mkSlowEntryCode cl_info reg_args = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) 0 reps_w_regs + load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) (CmmLoad (cmmRegOffW spReg offset) @@ -374,7 +375,8 @@ mkSlowEntryCode cl_info reg_args stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) + live_regs = Just $ map snd reps_w_regs + jump_to_entry = CmmJump (mkLblExpr (entryLabelFromCI cl_info)) live_regs \end{code} @@ -412,6 +414,7 @@ funWrapper :: ClosureInfo -- Closure whose code body this is -> Code funWrapper closure_info arg_regs reg_save_code fun_body = do { let node_points = nodeMustPointToIt (closureLFInfo closure_info) + live = Just $ map snd arg_regs {- -- Debugging: check that R1 has the correct tag @@ -431,8 +434,7 @@ funWrapper closure_info arg_regs reg_save_code fun_body = do ; granYield arg_regs node_points -- Heap and/or stack checks wrap the function body - ; funEntryChecks closure_info reg_save_code - fun_body + ; funEntryChecks closure_info reg_save_code live fun_body } \end{code} @@ -590,7 +592,7 @@ link_caf cl_info _is_upd = do -- assuming lots of things, like the stack pointer hasn't -- moved since we entered the CAF. let target = entryCode (closureInfoPtr (CmmReg nodeReg)) in - stmtC (CmmJump target) + stmtC (CmmJump target $ Just [node]) ; returnFC hp_rel } where diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 99690945cb..9049504dca 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -116,7 +116,7 @@ buildDynCon :: Id -- Name of the thing to which this constr will -> CostCentreStack -- Where to grab cost centre from; -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor - -> [(CgRep,CmmExpr)] -- Its args + -> [(CgRep,CmmExpr)] -- Its args -> FCode CgIdInfo -- Return details about how to find it buildDynCon binder ccs con args = do dflags <- getDynFlags @@ -348,12 +348,15 @@ cgReturnDataCon con amodes | otherwise -> build_it_then (jump_to deflt_lbl) } _otherwise -- The usual case - -> build_it_then emitReturnInstr + -> build_it_then $ emitReturnInstr node_live } where + node_live = Just [node] enter_it = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)), - CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg)))] - jump_to lbl = stmtC (CmmJump (CmmLit lbl)) + CmmJump (entryCode $ closureInfoPtr $ CmmReg nodeReg) + node_live + ] + jump_to lbl = stmtC $ CmmJump (CmmLit lbl) node_live build_it_then return_code = do { -- BUILD THE OBJECT IN THE HEAP -- The first "con" says that the name bound to this @@ -472,7 +475,7 @@ cgDataCon data_con -- The case continuation code is expecting a tagged pointer ; stmtC (CmmAssign nodeReg (tagCons data_con (CmmReg nodeReg))) - ; performReturn emitReturnInstr } + ; performReturn $ emitReturnInstr (Just []) } -- noStmts: Ptr to thing already in Node ; whenC (not (isNullaryRepDataCon data_con)) diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index e69db9f61b..cb3a86ef7f 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -149,7 +149,7 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) - ; performReturn emitReturnInstr } + ; performReturn $ emitReturnInstr (Just [node]) } where -- If you're reading this code in the attempt to figure -- out why the compiler panic'ed here, it is probably because @@ -172,7 +172,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args emptyVarSet - performReturn emitReturnInstr + -- ToDo: STG Live -- worried about this + performReturn $ emitReturnInstr (Just []) | ReturnsPrim rep <- result_info = do res <- newTemp (typeCmmType res_ty) @@ -191,7 +192,8 @@ cgExpr (StgOpApp (StgPrimOp primop) args res_ty) stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg (CmmLocal tag_reg)))) - performReturn emitReturnInstr + -- ToDo: STG Live -- worried about this + performReturn $ emitReturnInstr (Just [node]) where result_info = getPrimOpResultInfo primop diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index d8ac298b58..dfe146dfc8 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -54,6 +54,7 @@ import Outputable import FastString import Data.List +import Data.Maybe (fromMaybe) \end{code} @@ -273,21 +274,22 @@ an automatic context switch is done. A heap/stack check at a function or thunk entry point. \begin{code} -funEntryChecks :: ClosureInfo -> CmmStmts -> Code -> Code -funEntryChecks cl_info reg_save_code code - = hpStkCheck cl_info True reg_save_code code +funEntryChecks :: ClosureInfo -> CmmStmts -> Maybe [GlobalReg] -> Code -> Code +funEntryChecks cl_info reg_save_code live code + = hpStkCheck cl_info True reg_save_code live code thunkEntryChecks :: ClosureInfo -> Code -> Code thunkEntryChecks cl_info code - = hpStkCheck cl_info False noStmts code + = hpStkCheck cl_info False noStmts (Just [node]) code hpStkCheck :: ClosureInfo -- Function closure -> Bool -- Is a function? (not a thunk) -> CmmStmts -- Register saves + -> Maybe [GlobalReg] -- Live registers -> Code -> Code -hpStkCheck cl_info is_fun reg_save_code code +hpStkCheck cl_info is_fun reg_save_code live code = getFinalStackHW $ \ spHw -> do { sp <- getRealSp ; let stk_words = spHw - sp @@ -295,17 +297,18 @@ hpStkCheck cl_info is_fun reg_save_code code { -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole codeOnly $ do - { do_checks stk_words hpHw full_save_code rts_label + { do_checks stk_words hpHw full_save_code rts_label full_live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } } where - node_asst + (node_asst, full_live) | nodeMustPointToIt (closureLFInfo cl_info) - = noStmts + = (noStmts, live) | otherwise - = oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + = (oneStmt (CmmAssign nodeReg (CmmLit (CmmLabel closure_lbl))) + ,Just $ node : fromMaybe [] live) -- Strictly speaking, we should tag node here. But if -- node doesn't point to the closure, the code for the closure -- cannot depend on the value of R1 anyway, so we're safe. @@ -349,12 +352,17 @@ altHeapCheck alt_type code { codeOnly $ do { do_checks 0 {- no stack chk -} hpHw noStmts {- nothign to save -} - (rts_label alt_type) + rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } where - rts_label PolyAlt = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1"))) + (rts_label, live) = gc_info alt_type + + mkL l = CmmLit . CmmLabel $ mkCmmCodeLabel rtsPackageId (fsLit l) + + gc_info PolyAlt = (mkL "stg_gc_unpt_r1" , Just [node]) + -- Do *not* enter R1 after a heap check in -- a polymorphic case. It might be a function -- and the entry code for a function (currently) @@ -362,22 +370,21 @@ altHeapCheck alt_type code -- -- However R1 is guaranteed to be a pointer - rts_label (AlgAlt _) = stg_gc_enter1 + gc_info (AlgAlt _) = (stg_gc_enter1, Just [node]) -- Enter R1 after the heap check; it's a pointer - rts_label (PrimAlt tc) - = CmmLit $ CmmLabel $ - case primRepToCgRep (tyConPrimRep tc) of - VoidArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs") - FloatArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_f1") - DoubleArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_d1") - LongArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_l1") + gc_info (PrimAlt tc) + = case primRepToCgRep (tyConPrimRep tc) of + VoidArg -> (mkL "stg_gc_noregs", Just []) + FloatArg -> (mkL "stg_gc_f1", Just [FloatReg 1]) + DoubleArg -> (mkL "stg_gc_d1", Just [DoubleReg 1]) + LongArg -> (mkL "stg_gc_l1", Just [LongReg 1]) -- R1 is boxed but unlifted: - PtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unpt_r1") + PtrArg -> (mkL "stg_gc_unpt_r1", Just [node]) -- R1 is unboxed: - NonPtrArg -> mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_unbx_r1") + NonPtrArg -> (mkL "stg_gc_unbx_r1", Just [node]) - rts_label (UbxTupAlt _) = panic "altHeapCheck" + gc_info (UbxTupAlt _) = panic "altHeapCheck" \end{code} @@ -404,7 +411,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code | otherwise = initHeapUsage $ \ hpHw -> do { codeOnly $ do { do_checks 0 {- no stack check -} hpHw - full_fail_code rts_label + full_fail_code rts_label live ; tickyAllocHeap hpHw } ; setRealHp hpHw ; code } @@ -413,6 +420,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr)) -- Ho ho ho! (CmmLit (mkWordCLit liveness)) liveness = mkRegLiveness regs ptrs nptrs + live = Just $ map snd regs rts_label = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut"))) \end{code} @@ -434,14 +442,15 @@ again on re-entry because someone else might have stolen the resource in the meantime. \begin{code} -do_checks :: WordOff -- Stack headroom - -> WordOff -- Heap headroom - -> CmmStmts -- Assignments to perform on failure - -> CmmExpr -- Rts address to jump to on failure +do_checks :: WordOff -- Stack headroom + -> WordOff -- Heap headroom + -> CmmStmts -- Assignments to perform on failure + -> CmmExpr -- Rts address to jump to on failure + -> Maybe [GlobalReg] -- Live registers -> Code -do_checks 0 0 _ _ = nopC +do_checks 0 0 _ _ _ = nopC -do_checks _ hp _ _ +do_checks _ hp _ _ _ | hp > bLOCKS_PER_MBLOCK * bLOCK_SIZE_W = sorry (unlines [ "Trying to allocate more than " ++ show (bLOCKS_PER_MBLOCK * bLOCK_SIZE) ++ " bytes.", @@ -450,21 +459,22 @@ do_checks _ hp _ _ "Suggestion: read data from a file instead of having large static data", "structures in the code."]) -do_checks stk hp reg_save_code rts_lbl +do_checks stk hp reg_save_code rts_lbl live = do_checks' (CmmLit (mkIntCLit (stk*wORD_SIZE))) (CmmLit (mkIntCLit (hp*wORD_SIZE))) - (stk /= 0) (hp /= 0) reg_save_code rts_lbl + (stk /= 0) (hp /= 0) reg_save_code rts_lbl live -- The offsets are now in *bytes* -do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr -> Code -do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl +do_checks' :: CmmExpr -> CmmExpr -> Bool -> Bool -> CmmStmts -> CmmExpr + -> Maybe [GlobalReg] -> Code +do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl live = do { doGranAllocate hp_expr -- The failure block: this saves the registers and jumps to -- the appropriate RTS stub. ; exit_blk_id <- forkLabelledCode $ do { ; emitStmts reg_save_code - ; stmtC (CmmJump rts_lbl) } + ; stmtC (CmmJump rts_lbl live) } -- In the case of a heap-check failure, we must also set -- HpAlloc. NB. HpAlloc is *only* set if Hp has been @@ -514,7 +524,8 @@ do_checks' stk_expr hp_expr stk_nonzero hp_nonzero reg_save_code rts_lbl \begin{code} hpChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code hpChkGen bytes liveness reentry - = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns stg_gc_gen + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assigns + stg_gc_gen (Just activeStgRegs) where assigns = mkStmts [ mk_vanilla_assignment 9 liveness, mk_vanilla_assignment 10 reentry ] @@ -523,12 +534,14 @@ hpChkGen bytes liveness reentry -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). hpChkNodePointsAssignSp0 :: CmmExpr -> CmmExpr -> Code hpChkNodePointsAssignSp0 bytes sp0 - = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign stg_gc_enter1 + = do_checks' (CmmLit (mkIntCLit 0)) bytes False True assign + stg_gc_enter1 (Just [node]) where assign = oneStmt (CmmStore (CmmReg spReg) sp0) stkChkGen :: CmmExpr -> CmmExpr -> CmmExpr -> Code stkChkGen bytes liveness reentry - = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns stg_gc_gen + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False assigns + stg_gc_gen (Just activeStgRegs) where assigns = mkStmts [ mk_vanilla_assignment 9 liveness, mk_vanilla_assignment 10 reentry ] @@ -539,7 +552,8 @@ mk_vanilla_assignment n e stkChkNodePoints :: CmmExpr -> Code stkChkNodePoints bytes - = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts stg_gc_enter1 + = do_checks' bytes (CmmLit (mkIntCLit 0)) True False noStmts + stg_gc_enter1 (Just [node]) stg_gc_gen :: CmmExpr stg_gc_gen = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_gen"))) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 9f003a2302..1e80616887 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -250,10 +250,10 @@ emitAlgReturnTarget name branches mb_deflt fam_sz -- global labels, so we can't use them at the 'call site' -------------------------------- -emitReturnInstr :: Code -emitReturnInstr - = do { info_amode <- getSequelAmode - ; stmtC (CmmJump (entryCode info_amode)) } +emitReturnInstr :: Maybe [GlobalReg] -> Code +emitReturnInstr live + = do { info_amode <- getSequelAmode + ; stmtC (CmmJump (entryCode info_amode) live) } ----------------------------------------------------------------------------- -- diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index c05019e3ac..c0e3e3be8b 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -249,7 +249,7 @@ flattenCgStmts id stmts = where (block,blocks) = flatten ss isJump :: CmmStmt -> Bool -isJump (CmmJump _ ) = True +isJump (CmmJump _ _) = True isJump (CmmBranch _ ) = True isJump (CmmSwitch _ _) = True isJump (CmmReturn ) = True diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 07be7f23fa..499529d841 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -45,6 +45,7 @@ import Outputable import StaticFlags import Control.Monad +import Data.Maybe ----------------------------------------------------------------------------- -- Tail Calls @@ -103,17 +104,19 @@ performTailCall fun_info arg_amodes pending_assts -- to make the heap check easier. The tail-call sequence -- is very similar to returning an unboxed tuple, so we -- share some code. - do { (final_sp, arg_assts) <- pushUnboxedTuple join_sp arg_amodes + do { (final_sp, arg_assts, live) <- pushUnboxedTuple join_sp arg_amodes ; emitSimultaneously (pending_assts `plusStmts` arg_assts) ; let lbl = enterReturnPtLabel (idUnique (cgIdInfoId fun_info)) - ; doFinalJump final_sp True {- Is LNE -} (jumpToLbl lbl) } + ; doFinalJump final_sp True $ jumpToLbl lbl (Just live) } | otherwise = do { fun_amode <- idInfoToAmode fun_info ; let assignSt = CmmAssign nodeReg fun_amode node_asst = oneStmt assignSt - opt_node_asst | nodeMustPointToIt lf_info = node_asst - | otherwise = noStmts + node_live = Just [node] + (opt_node_asst, opt_node_live) + | nodeMustPointToIt lf_info = (node_asst, node_live) + | otherwise = (noStmts, Just []) ; EndOfBlockInfo sp _ <- getEndOfBlockInfo ; dflags <- getDynFlags @@ -122,8 +125,8 @@ performTailCall fun_info arg_amodes pending_assts -- Node must always point to things we enter EnterIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) - enterClosure = stmtC (CmmJump target) + ; let target = entryCode (closureInfoPtr (CmmReg nodeReg)) + enterClosure = stmtC (CmmJump target node_live) -- If this is a scrutinee -- let's check if the closure is a constructor -- so we can directly jump to the alternatives switch @@ -137,18 +140,18 @@ performTailCall fun_info arg_amodes pending_assts -- As with any return, Node must point to it. ReturnIt -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False emitReturnInstr } + ; doFinalJump sp False $ emitReturnInstr node_live } -- A real constructor. Don't bother entering it, -- just do the right sort of return instead. -- As with any return, Node must point to it. ReturnCon _ -> do { emitSimultaneously (node_asst `plusStmts` pending_assts) - ; doFinalJump sp False emitReturnInstr } + ; doFinalJump sp False $ emitReturnInstr node_live } JumpToIt lbl -> do { emitSimultaneously (opt_node_asst `plusStmts` pending_assts) - ; doFinalJump sp False (jumpToLbl lbl) } + ; doFinalJump sp False $ jumpToLbl lbl opt_node_live } -- A slow function call via the RTS apply routines -- Node must definitely point to the thing @@ -163,7 +166,7 @@ performTailCall fun_info arg_amodes pending_assts ; let (apply_lbl, args, extra_args) = constructSlowCall arg_amodes - ; directCall sp apply_lbl args extra_args + ; directCall sp apply_lbl args extra_args node_live (node_asst `plusStmts` pending_assts) } @@ -179,7 +182,7 @@ performTailCall fun_info arg_amodes pending_assts -- The args beyond the arity go straight on the stack (arity_args, extra_args) = splitAt arity arg_amodes - ; directCall sp lbl arity_args extra_args + ; directCall sp lbl arity_args extra_args opt_node_live (opt_node_asst `plusStmts` pending_assts) } } @@ -203,7 +206,8 @@ performTailCall fun_info arg_amodes pending_assts -- No, enter the closure. ; enterClosure ; labelC is_constr - ; stmtC (CmmJump (entryCode $ CmmLit (CmmLabel lbl))) + ; stmtC (CmmJump (entryCode $ + CmmLit (CmmLabel lbl)) (Just [node])) } {- -- This is a scrutinee for a case expression @@ -243,9 +247,9 @@ performTailCall fun_info arg_amodes pending_assts -} directCall :: VirtualSpOffset -> CLabel -> [(CgRep, CmmExpr)] - -> [(CgRep, CmmExpr)] -> CmmStmts + -> [(CgRep, CmmExpr)] -> Maybe [GlobalReg] -> CmmStmts -> Code -directCall sp lbl args extra_args assts = do +directCall sp lbl args extra_args live_node assts = do let -- First chunk of args go in registers (reg_arg_amodes, stk_args) = assignCallRegs args @@ -255,14 +259,12 @@ directCall sp lbl args extra_args assts = do slow_stk_args = slowArgs extra_args reg_assts = assignToRegs reg_arg_amodes + live_args = map snd reg_arg_amodes + live_regs = Just $ (fromMaybe [] live_node) ++ live_args -- (final_sp, stk_assts) <- mkStkAmodes sp (stk_args ++ slow_stk_args) - - emitSimultaneously (reg_assts `plusStmts` - stk_assts `plusStmts` - assts) - - doFinalJump final_sp False (jumpToLbl lbl) + emitSimultaneously $ reg_assts `plusStmts` stk_assts `plusStmts` assts + doFinalJump final_sp False $ jumpToLbl lbl live_regs -- ----------------------------------------------------------------------------- -- The final clean-up before we do a jump at the end of a basic block. @@ -296,20 +298,27 @@ performReturn :: Code -- The code to execute to actually do the return performReturn finish_code = do { EndOfBlockInfo args_sp _sequel <- getEndOfBlockInfo - ; doFinalJump args_sp False{-not a LNE-} finish_code } + ; doFinalJump args_sp False finish_code } -- ---------------------------------------------------------------------------- -- Primitive Returns -- Just load the return value into the right register, and return. -performPrimReturn :: CgRep -> CmmExpr -- The thing to return - -> Code -performPrimReturn rep amode - = do { whenC (not (isVoidArg rep)) - (stmtC (CmmAssign ret_reg amode)) - ; performReturn emitReturnInstr } +performPrimReturn :: CgRep -> CmmExpr -> Code + +-- non-void return value +performPrimReturn rep amode | not (isVoidArg rep) + = do { stmtC (CmmAssign ret_reg amode) + ; performReturn $ emitReturnInstr live_regs } where - ret_reg = dataReturnConvPrim rep + -- careful here as 'dataReturnConvPrim' will panic if given a Void rep + ret_reg@(CmmGlobal r) = dataReturnConvPrim rep + live_regs = Just [r] + +-- void return value +performPrimReturn _ _ + = performReturn $ emitReturnInstr (Just []) + -- --------------------------------------------------------------------------- -- Unboxed tuple returns @@ -329,19 +338,21 @@ returnUnboxedTuple :: [(CgRep, CmmExpr)] -> Code returnUnboxedTuple amodes = do { (EndOfBlockInfo args_sp _sequel) <- getEndOfBlockInfo ; tickyUnboxedTupleReturn (length amodes) - ; (final_sp, assts) <- pushUnboxedTuple args_sp amodes + ; (final_sp, assts, live_regs) <- pushUnboxedTuple args_sp amodes ; emitSimultaneously assts - ; doFinalJump final_sp False{-not a LNE-} emitReturnInstr } + ; doFinalJump final_sp False $ emitReturnInstr (Just live_regs) } pushUnboxedTuple :: VirtualSpOffset -- Sp at which to start pushing -> [(CgRep, CmmExpr)] -- amodes of the components -> FCode (VirtualSpOffset, -- final Sp - CmmStmts) -- assignments (regs+stack) + CmmStmts, -- assignments (regs+stack) + [GlobalReg]) -- registers used (liveness) pushUnboxedTuple sp [] - = return (sp, noStmts) + = return (sp, noStmts, []) pushUnboxedTuple sp amodes = do { let (reg_arg_amodes, stk_arg_amodes) = assignReturnRegs amodes + live_regs = map snd reg_arg_amodes -- separate the rest of the args into pointers and non-pointers (ptr_args, nptr_args) = separateByPtrFollowness stk_arg_amodes @@ -352,8 +363,8 @@ pushUnboxedTuple sp amodes ; (final_sp, nptr_assts) <- mkStkAmodes ptr_sp nptr_args ; returnFC (final_sp, - reg_arg_assts `plusStmts` - ptr_assts `plusStmts` nptr_assts) } + reg_arg_assts `plusStmts` ptr_assts `plusStmts` nptr_assts, + live_regs) } -- ----------------------------------------------------------------------------- @@ -403,13 +414,14 @@ tailCallPrim lbl args -- Hence the ASSERT( null leftovers ) arg_amodes <- getArgAmodes args ; let (arg_regs, leftovers) = assignPrimOpCallRegs arg_amodes - jump_to_primop = jumpToLbl lbl + live_regs = Just $ map snd arg_regs + jump_to_primop = jumpToLbl lbl live_regs ; ASSERT(null leftovers) -- no stack-resident args emitSimultaneously (assignToRegs arg_regs) ; EndOfBlockInfo args_sp _ <- getEndOfBlockInfo - ; doFinalJump args_sp False{-not a LNE-} jump_to_primop } + ; doFinalJump args_sp False jump_to_primop } -- ----------------------------------------------------------------------------- -- Return Addresses @@ -439,8 +451,8 @@ pushReturnAddress _ = nopC -- Misc. -- Passes no argument to the destination procedure -jumpToLbl :: CLabel -> Code -jumpToLbl lbl = stmtC (CmmJump (CmmLit (CmmLabel lbl))) +jumpToLbl :: CLabel -> Maybe [GlobalReg] -> Code +jumpToLbl lbl live = stmtC $ CmmJump (CmmLit $ CmmLabel lbl) live assignToRegs :: [(CmmExpr, GlobalReg)] -> CmmStmts assignToRegs reg_args diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2a524a182c..2bd35c8796 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -1020,7 +1020,7 @@ fixStgRegStmt stmt CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids - CmmJump addr -> CmmJump (fixStgRegExpr addr) + CmmJump addr live -> CmmJump (fixStgRegExpr addr) live -- CmmNop, CmmComment, CmmBranch, CmmReturn _other -> stmt diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 3b8b559f38..a8ec371441 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -105,7 +105,7 @@ find an occurence of an Id, we fetch it from the in-scope set. \begin{code} -lintCoreBindings :: CoreProgram -> (Bag Message, Bag Message) +lintCoreBindings :: CoreProgram -> (Bag MsgDoc, Bag MsgDoc) -- Returns (warnings, errors) lintCoreBindings binds = initL $ @@ -150,7 +150,7 @@ We use this to check all unfoldings that come in from interfaces lintUnfolding :: SrcLoc -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe Message -- Nothing => OK + -> Maybe MsgDoc -- Nothing => OK lintUnfolding locn vars expr | isEmptyBag errs = Nothing @@ -915,7 +915,7 @@ newtype LintM a = WarnsAndErrs -> -- Error and warning messages so far (Maybe a, WarnsAndErrs) } -- Result and messages (if any) -type WarnsAndErrs = (Bag Message, Bag Message) +type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) {- Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -963,23 +963,23 @@ initL m \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg -failWithL :: Message -> LintM a +failWithL :: MsgDoc -> LintM a failWithL msg = LintM $ \ loc subst (warns,errs) -> (Nothing, (warns, addMsg subst errs msg loc)) -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (warns, addMsg subst errs msg loc)) -addWarnL :: Message -> LintM () +addWarnL :: MsgDoc -> LintM () addWarnL msg = LintM $ \ loc subst (warns,errs) -> (Just (), (addMsg subst warns msg loc, errs)) -addMsg :: TvSubst -> Bag Message -> Message -> [LintLocInfo] -> Bag Message +addMsg :: TvSubst -> Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addMsg subst msgs msg locs = ASSERT( notNull locs ) msgs `snocBag` mk_msg msg @@ -990,7 +990,7 @@ addMsg subst msgs msg locs ptext (sLit "Substitution:") <+> ppr subst | otherwise = cxt1 - mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) + mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m = @@ -1062,7 +1062,7 @@ checkInScope loc_msg var = ; checkL (not (mustHaveLocalBinding var) || (var `isInScope` subst)) (hsep [ppr var, loc_msg]) } -checkTys :: OutType -> OutType -> Message -> LintM () +checkTys :: OutType -> OutType -> MsgDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied @@ -1120,39 +1120,39 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkNullAltsMsg :: CoreExpr -> Message +mkNullAltsMsg :: CoreExpr -> MsgDoc mkNullAltsMsg e = hang (text "Case expression with no alternatives:") 4 (ppr e) -mkDefaultArgsMsg :: [Var] -> Message +mkDefaultArgsMsg :: [Var] -> MsgDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> Message +mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ppr ty1, ppr ty2, ppr e]) -mkScrutMsg :: Id -> Type -> Type -> TvSubst -> Message +mkScrutMsg :: Id -> Type -> Type -> TvSubst -> MsgDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, hsep [ptext (sLit "Current TV subst"), ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> Message +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e) mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> Message +nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> Message +mkBadConMsg :: TyCon -> DataCon -> MsgDoc mkBadConMsg tycon datacon = vcat [ text "In a case alternative, data constructor isn't in scrutinee type:", @@ -1160,7 +1160,7 @@ mkBadConMsg tycon datacon text "Data con:" <+> ppr datacon ] -mkBadPatMsg :: Type -> Type -> Message +mkBadPatMsg :: Type -> Type -> MsgDoc mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -1168,17 +1168,17 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] -integerScrutinisedMsg :: Message +integerScrutinisedMsg :: MsgDoc integerScrutinisedMsg = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> Message +mkBadAltMsg :: Type -> CoreAlt -> MsgDoc mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> Message +mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc mkNewTyDataConAltMsg scrut_ty alt = vcat [ text "Data alternative for newtype datacon", text "Scrutinee type:" <+> ppr scrut_ty, @@ -1188,21 +1188,21 @@ mkNewTyDataConAltMsg scrut_ty alt ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> Message +mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Argument value doesn't match argument type:"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc mkNonFunAppMsg fun_ty arg_ty arg = vcat [ptext (sLit "Non-function type in function position"), hang (ptext (sLit "Fun type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> Message +mkLetErr :: TyVar -> CoreExpr -> MsgDoc mkLetErr bndr rhs = vcat [ptext (sLit "Bad `let' binding:"), hang (ptext (sLit "Variable:")) @@ -1210,7 +1210,7 @@ mkLetErr bndr rhs hang (ptext (sLit "Rhs:")) 4 (ppr rhs)] -mkTyCoAppErrMsg :: TyVar -> Coercion -> Message +mkTyCoAppErrMsg :: TyVar -> Coercion -> MsgDoc mkTyCoAppErrMsg tyvar arg_co = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), hang (ptext (sLit "Type variable:")) @@ -1218,7 +1218,7 @@ mkTyCoAppErrMsg tyvar arg_co hang (ptext (sLit "Arg coercion:")) 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkTyAppMsg :: Type -> Type -> Message +mkTyAppMsg :: Type -> Type -> MsgDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (ptext (sLit "Exp type:")) @@ -1226,7 +1226,7 @@ mkTyAppMsg ty arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkRhsMsg :: Id -> Type -> Message +mkRhsMsg :: Id -> Type -> MsgDoc mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), @@ -1234,14 +1234,14 @@ mkRhsMsg binder ty hsep [ptext (sLit "Binder's type:"), ppr (idType binder)], hsep [ptext (sLit "Rhs type:"), ppr ty]] -mkRhsPrimMsg :: Id -> CoreExpr -> Message +mkRhsPrimMsg :: Id -> CoreExpr -> MsgDoc mkRhsPrimMsg binder _rhs = vcat [hsep [ptext (sLit "The type of this binder is primitive:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)] ] -mkStrictMsg :: Id -> Message +mkStrictMsg :: Id -> MsgDoc mkStrictMsg binder = vcat [hsep [ptext (sLit "Recursive or top-level binder has strict demand info:"), ppr binder], @@ -1249,7 +1249,7 @@ mkStrictMsg binder ] -mkKindErrMsg :: TyVar -> Type -> Message +mkKindErrMsg :: TyVar -> Type -> MsgDoc mkKindErrMsg tyvar arg_ty = vcat [ptext (sLit "Kinds don't match in type application:"), hang (ptext (sLit "Type variable:")) @@ -1257,7 +1257,7 @@ mkKindErrMsg tyvar arg_ty hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkArityMsg :: Id -> Message +mkArityMsg :: Id -> MsgDoc mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has "), ppr (dmdTypeDepth dmd_ty), @@ -1270,24 +1270,24 @@ mkArityMsg binder ] where (StrictSig dmd_ty) = idStrictness binder -mkUnboxedTupleMsg :: Id -> Message +mkUnboxedTupleMsg :: Id -> MsgDoc mkUnboxedTupleMsg binder = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] -mkCastErr :: Type -> Type -> Message +mkCastErr :: Type -> Type -> MsgDoc mkCastErr from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty ] -dupVars :: [[Var]] -> Message +dupVars :: [[Var]] -> MsgDoc dupVars vars = hang (ptext (sLit "Duplicate variables brought into scope")) 2 (ppr vars) -dupExtVars :: [[Name]] -> Message +dupExtVars :: [[Name]] -> MsgDoc dupExtVars vars = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) @@ -1320,7 +1320,7 @@ lintSplitCoVar cv Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) -mkCoVarLetErr :: CoVar -> Coercion -> Message +mkCoVarLetErr :: CoVar -> Coercion -> MsgDoc mkCoVarLetErr covar co = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), hang (ptext (sLit "Coercion variable:")) @@ -1328,7 +1328,7 @@ mkCoVarLetErr covar co hang (ptext (sLit "Arg coercion:")) 4 (ppr co)] -mkCoAppErrMsg :: CoVar -> Coercion -> Message +mkCoAppErrMsg :: CoVar -> Coercion -> MsgDoc mkCoAppErrMsg covar arg_co = vcat [ptext (sLit "Kinds don't match in coercion application:"), hang (ptext (sLit "Coercion variable:")) @@ -1337,7 +1337,7 @@ mkCoAppErrMsg covar arg_co 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] -mkCoAppMsg :: Type -> Coercion -> Message +mkCoAppMsg :: Type -> Coercion -> MsgDoc mkCoAppMsg ty arg_co = vcat [text "Illegal type application:", hang (ptext (sLit "exp type:")) diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index a41302d5d3..c18af8e189 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -26,6 +26,7 @@ module CoreSyn ( mkIntLit, mkIntLitInt, mkWordLit, mkWordLitWord, + mkWord64LitWord64, mkInt64LitInt64, mkCharLit, mkStringLit, mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, @@ -104,6 +105,7 @@ import Outputable import Util import Data.Data hiding (TyCon) +import Data.Int import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` @@ -1044,6 +1046,12 @@ mkWordLitWord :: Word -> Expr b mkWordLit w = Lit (mkMachWord w) mkWordLitWord w = Lit (mkMachWord (toInteger w)) +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkMachWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkMachInt64 (toInteger w)) + -- | Create a machine character literal expression of type @Char#@. -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' mkCharLit :: Char -> Expr b diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 7ff5e69686..4320934f8e 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -32,7 +32,8 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things -import HscTypes(MonadThings) +import HscTypes ( MonadThings ) +import Literal ( Literal(MachStr) ) import CoreSubst import MkCore import CoreUtils @@ -41,6 +42,7 @@ import CoreUnfold import CoreFVs import Digraph + import TyCon ( isTupleTyCon, tyConDataCons_maybe ) import TcEvidence import TcType @@ -712,7 +714,11 @@ dsEvTerm (EvSuperClass d n) = return $ Var sc_sel_id `mkTyApps` tys `App` Var d where sc_sel_id = classSCSelId cls n -- Zero-indexed - (cls, tys) = getClassPredTys (evVarPred d) + (cls, tys) = getClassPredTys (evVarPred d) +dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] + where + errorId = rUNTIME_ERROR_ID + litMsg = Lit (MachStr msg) dsEvTerm (EvInteger n) = mkIntegerExpr n diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index bf05fdffe2..551165a3ad 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -226,7 +226,7 @@ initDs hsc_env mod rdr_env type_env thing_inside where loadOneModule :: ModuleName -- the module to load -> DsM Bool -- under which condition - -> Message -- error message if module not found + -> MsgDoc -- error message if module not found -> DsM GlobalRdrEnv -- empty if condition 'False' loadOneModule modname check err = do { doLoad <- check @@ -370,8 +370,7 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) warnDs :: SDoc -> DsM () warnDs warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkWarnMsg loc (ds_unqual env) - (ptext (sLit "Warning:") <+> warn) + ; let msg = mkWarnMsg loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } failWithDs :: SDoc -> DsM a diff --git a/compiler/ghc.mk b/compiler/ghc.mk index a78255fecb..8790df361e 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -258,7 +258,7 @@ PRIMOP_BITS = compiler/primop-data-decl.hs-incl \ compiler/primop-strictness.hs-incl \ compiler/primop-primop-info.hs-incl -compiler_CPP_OPTS += -I$(GHC_INCLUDE_DIR) +compiler_CPP_OPTS += $(addprefix -I,$(GHC_INCLUDE_DIRS)) compiler_CPP_OPTS += ${GhcCppOpts} $(PRIMOPS_TXT) compiler/parser/Parser.y: %: %.pp compiler/stage1/$(PLATFORM_H) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3e9ab43579..f4ad61757f 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -443,8 +443,8 @@ linkExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: SrcSpan -> Message -> IO a -dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg))) +dieWith :: SrcSpan -> MsgDoc -> IO a +dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage SevFatal span msg))) checkNonStdWay :: DynFlags -> SrcSpan -> IO Bool diff --git a/compiler/ghci/ObjLink.lhs b/compiler/ghci/ObjLink.lhs index f467c7ada3..dedc9ceb2f 100644 --- a/compiler/ghci/ObjLink.lhs +++ b/compiler/ghci/ObjLink.lhs @@ -36,12 +36,7 @@ import Control.Monad ( when ) import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) -#if __GLASGOW_HASKELL__ >= 703 -import GHC.IO.Encoding (getFileSystemEncoding) -#else -import GHC.IO.Encoding (TextEncoding, fileSystemEncoding) -#endif -import qualified GHC.Foreign as GHC +import System.Posix.Internals ( CFilePath, withFilePath ) import System.FilePath ( dropExtension ) @@ -49,21 +44,10 @@ import System.FilePath ( dropExtension ) -- RTS Linker Interface -- --------------------------------------------------------------------------- -#if __GLASGOW_HASKELL__ < 703 -getFileSystemEncoding :: IO TextEncoding -getFileSystemEncoding = return fileSystemEncoding -#endif - --- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page -withFileCString :: FilePath -> (CString -> IO a) -> IO a -withFileCString fp f = do - enc <- getFileSystemEncoding - GHC.withCString enc fp f - insertSymbol :: String -> String -> Ptr a -> IO () insertSymbol obj_name key symbol = let str = prefixUnderscore key - in withFileCString obj_name $ \c_obj_name -> + in withFilePath obj_name $ \c_obj_name -> withCAString str $ \c_str -> c_insertSymbol c_obj_name c_str symbol @@ -99,7 +83,7 @@ loadDLL str0 = do str | isWindowsHost = dropExtension str0 | otherwise = str0 -- - maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll + maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return Nothing else do str <- peekCString maybe_errmsg @@ -107,19 +91,19 @@ loadDLL str0 = do loadArchive :: String -> IO () loadArchive str = do - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_loadArchive c_str when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) loadObj :: String -> IO () loadObj str = do - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_loadObj c_str when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) unloadObj :: String -> IO () unloadObj str = - withFileCString str $ \c_str -> do + withFilePath str $ \c_str -> do r <- c_unloadObj c_str when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) @@ -132,12 +116,12 @@ resolveObjs = do -- Foreign declarations to RTS entry points which does the real work; -- --------------------------------------------------------------------------- -foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString +foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString foreign import ccall unsafe "initLinker" initObjLinker :: IO () -foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO () +foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO () foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) -foreign import ccall unsafe "loadArchive" c_loadArchive :: CString -> IO Int -foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int -foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int +foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int +foreign import ccall unsafe "loadObj" c_loadObj :: CFilePath -> IO Int +foreign import ccall unsafe "unloadObj" c_unloadObj :: CFilePath -> IO Int foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int \end{code} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index f294a1b8c5..4292a112ff 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -48,25 +48,25 @@ import GHC.Exts ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName] +convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName] convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName) +convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName) convertToHsExpr loc e = initCvt loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName) +convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName) convertToPat loc p = initCvt loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName) +convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName) convertToHsType loc t = initCvt loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a } +newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc a } -- Push down the source location; -- Can fail, with a single error message @@ -85,13 +85,13 @@ instance Monad CvtM where Left err -> Left err Right v -> unCvtM (k v) loc -initCvt :: SrcSpan -> CvtM a -> Either Message a +initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a initCvt loc (CvtM m) = m loc force :: a -> CvtM () force a = a `seq` return () -failWith :: Message -> CvtM a +failWith :: MsgDoc -> CvtM a failWith m = CvtM (\_ -> Left m) getL :: CvtM SrcSpan @@ -232,7 +232,7 @@ cvtDec (TySynInstD tc tys rhs) ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') } ---------------- -cvt_ci_decs :: Message -> [TH.Dec] +cvt_ci_decs :: MsgDoc -> [TH.Dec] -> CvtM (LHsBinds RdrName, [LSig RdrName], [LTyClDecl RdrName]) @@ -304,7 +304,7 @@ is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName) is_bind (L loc (Hs.ValD bind)) = Left (L loc bind) is_bind decl = Right decl -mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message +mkBadDecMsg :: MsgDoc -> [LHsDecl RdrName] -> MsgDoc mkBadDecMsg doc bads = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -437,7 +437,7 @@ cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation)) -- Declarations --------------------------------------------------- -cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) +cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName) cvtLocalDecs doc ds | null ds = return EmptyLocalBinds diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index ec1205f83d..37379b5be4 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -167,7 +167,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr Message ModIface) + -> IfM lcl (MaybeErr MsgDoc ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -294,7 +294,7 @@ loadInterface doc_str mod from }}}} wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr Message IsBootInterface + -> MaybeErr MsgDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile dflags eps mod from = case from of @@ -472,7 +472,7 @@ bumpDeclStats name findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -537,7 +537,7 @@ findAndReadIface doc_str mod hi_boot_file \begin{code} readIface :: Module -> FilePath -> IsBootInterface - -> TcRnIf gbl lcl (MaybeErr Message ModIface) + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -794,7 +794,7 @@ badIfaceFile file err = vcat [ptext (sLit "Bad interface file:") <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> Message +hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc hiModuleNameMismatchWarn requested_mod read_mod = withPprStyle defaultUserStyle $ -- we want the Modules below to be qualified with package names, diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 4e8c96b962..35b4c91f2a 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -844,7 +844,7 @@ oldMD5 dflags bh = do instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg instOrphWarn unqual inst = mkWarnMsg (getSrcSpan inst) unqual $ - hang (ptext (sLit "Warning: orphan instance:")) 2 (pprInstanceHdr inst) + hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst) ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg ruleOrphWarn unqual mod rule diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 36ca30ee04..1854b77f87 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -125,7 +125,7 @@ tcImportDecl name Succeeded thing -> return thing Failed err -> failWithTc err } -importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs index aec492e151..b15b6f261d 100644 --- a/compiler/llvmGen/Llvm.hs +++ b/compiler/llvmGen/Llvm.hs @@ -34,6 +34,9 @@ module Llvm ( -- ** Some basic types i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr, + -- ** Metadata types + LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData, + -- ** Operations on the type system. isGlobal, getLitType, getLit, getName, getPlainName, getVarType, getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower, @@ -42,7 +45,8 @@ module Llvm ( -- * Pretty Printing ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, - ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, llvmSDoc + ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta, + llvmSDoc ) where diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs index 93bc62c91f..a28734b152 100644 --- a/compiler/llvmGen/Llvm/AbsSyn.hs +++ b/compiler/llvmGen/Llvm/AbsSyn.hs @@ -31,6 +31,9 @@ data LlvmModule = LlvmModule { -- | LLVM Alias type definitions. modAliases :: [LlvmAlias], + -- | LLVM meta data. + modMeta :: [LlvmMeta], + -- | Global variables to include in the module. modGlobals :: [LMGlobal], @@ -138,8 +141,15 @@ data LlvmStatement -} | Nop + {- | + A LLVM statement with metadata attached to it. + -} + | MetaStmt [MetaData] LlvmStatement + deriving (Show, Eq) +type MetaData = (LMString, LlvmMetaUnamed) + -- | Llvm Expressions data LlvmExpression @@ -229,5 +239,10 @@ data LlvmExpression -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool + {- | + A LLVM expression with metadata attached to it. + -} + | MetaExpr [MetaData] LlvmExpression + deriving (Show, Eq) diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs index 217d02debf..2945777f96 100644 --- a/compiler/llvmGen/Llvm/PpLlvm.hs +++ b/compiler/llvmGen/Llvm/PpLlvm.hs @@ -10,8 +10,10 @@ module Llvm.PpLlvm ( ppLlvmComment, ppLlvmGlobals, ppLlvmGlobal, - ppLlvmAlias, ppLlvmAliases, + ppLlvmAlias, + ppLlvmMetas, + ppLlvmMeta, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions, @@ -38,15 +40,12 @@ import Unique -- | Print out a whole LLVM module. ppLlvmModule :: LlvmModule -> Doc -ppLlvmModule (LlvmModule comments aliases globals decls funcs) - = ppLlvmComments comments - $+$ empty - $+$ ppLlvmAliases aliases - $+$ empty - $+$ ppLlvmGlobals globals - $+$ empty - $+$ ppLlvmFunctionDecls decls - $+$ empty +ppLlvmModule (LlvmModule comments aliases meta globals decls funcs) + = ppLlvmComments comments $+$ newLine + $+$ ppLlvmAliases aliases $+$ newLine + $+$ ppLlvmMetas meta $+$ newLine + $+$ ppLlvmGlobals globals $+$ newLine + $+$ ppLlvmFunctionDecls decls $+$ newLine $+$ ppLlvmFunctions funcs -- | Print out a multi-line comment, can be inside a function or on its own @@ -80,6 +79,7 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) = const' = if c then text "constant" else text "global" in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align + $+$ newLine ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth @@ -90,7 +90,33 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys -- | Print out an LLVM type alias. ppLlvmAlias :: LlvmAlias -> Doc -ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty +ppLlvmAlias (name, ty) + = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty + + +-- | Print out a list of LLVM metadata. +ppLlvmMetas :: [LlvmMeta] -> Doc +ppLlvmMetas metas = vcat $ map ppLlvmMeta metas + +-- | Print out an LLVM metadata definition. +ppLlvmMeta :: LlvmMeta -> Doc +ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas) + = exclamation <> int u <> text " = metadata !{" <> + hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}" + +ppLlvmMeta (MetaNamed n metas) + = exclamation <> ftext n <> text " = !{" <> + hcat (intersperse comma $ map pprNode munq) <> text "}" + where + munq = map (\(LMMetaUnamed u) -> u) metas + pprNode n = exclamation <> int n + +-- | Print out an LLVM metadata value. +ppLlvmMetaVal :: LlvmMetaVal -> Doc +ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s) +ppLlvmMetaVal (MetaVar v) = texts v +ppLlvmMetaVal (MetaNode (LMMetaUnamed u)) + = text "metadata !" <> int u -- | Print out a list of function definitions. @@ -109,6 +135,8 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) = $+$ lbrace $+$ ppLlvmBlocks body $+$ rbrace + $+$ newLine + $+$ newLine -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc @@ -126,7 +154,6 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align - -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs @@ -146,7 +173,7 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) args = hcat $ intersperse (comma <> space) $ map (\(t,a) -> texts t <+> ppSpaceJoin a) p in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> - ftext n <> lparen <> args <> varg' <> rparen <> align + ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks. @@ -157,25 +184,44 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks -- It must be part of a function definition. ppLlvmBlock :: LlvmBlock -> Doc ppLlvmBlock (LlvmBlock blockId stmts) - = ppLlvmStatement (MkLabel blockId) - $+$ nest 4 (vcat $ map ppLlvmStatement stmts) + = go blockId stmts + where + lbreak acc [] = (Nothing, reverse acc, []) + lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs) + lbreak acc (x:xs) = lbreak (x:acc) xs + + go id code = + let (id2, block, rest) = lbreak [] code + ppRest = case id2 of + Just id2' -> go id2' rest + Nothing -> empty + in ppLlvmBlockLabel id + $+$ (vcat $ map ppLlvmStatement block) + $+$ newLine + $+$ ppRest + +-- | Print out an LLVM block label. +ppLlvmBlockLabel :: LlvmBlockId -> Doc +ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon -- | Print out an LLVM statement. ppLlvmStatement :: LlvmStatement -> Doc -ppLlvmStatement stmt - = case stmt of - Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr) - Branch target -> ppBranch target - BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF - Comment comments -> ppLlvmComments comments - MkLabel label -> (llvmSDoc $ pprUnique label) <> colon - Store value ptr -> ppStore value ptr - Switch scrut def tgs -> ppSwitch scrut def tgs - Return result -> ppReturn result - Expr expr -> ppLlvmExpression expr - Unreachable -> text "unreachable" +ppLlvmStatement stmt = + let ind = (text " " <>) + in case stmt of + Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr) + Branch target -> ind $ ppBranch target + BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF + Comment comments -> ind $ ppLlvmComments comments + MkLabel label -> ppLlvmBlockLabel label + Store value ptr -> ind $ ppStore value ptr + Switch scrut def tgs -> ind $ ppSwitch scrut def tgs + Return result -> ind $ ppReturn result + Expr expr -> ind $ ppLlvmExpression expr + Unreachable -> ind $ text "unreachable" Nop -> empty + MetaStmt meta s -> ppMetaStatement meta s -- | Print out an LLVM expression. @@ -192,6 +238,7 @@ ppLlvmExpression expr Malloc tp amount -> ppMalloc tp amount Phi tp precessors -> ppPhi tp precessors Asm asm c ty v se sk -> ppAsm asm c ty v se sk + MetaExpr meta expr -> ppMetaExpr meta expr -------------------------------------------------------------------------------- @@ -327,6 +374,21 @@ ppAsm asm constraints rty vars sideeffect alignstack = <+> cons <> vars' +ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc +ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta + + +ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc +ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta + + +ppMetas :: [MetaData] -> Doc +ppMetas meta = hcat $ map ppMeta meta + where + ppMeta (name, (LMMetaUnamed n)) + = comma <+> exclamation <> ftext name <+> exclamation <> int n + + -------------------------------------------------------------------------------- -- * Misc functions -------------------------------------------------------------------------------- @@ -344,3 +406,11 @@ llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d texts :: (Show a) => a -> Doc texts = (text . show) +-- | Blank line. +newLine :: Doc +newLine = text "" + +-- | Exclamation point. +exclamation :: Doc +exclamation = text "!" + diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index 101342606d..07e53fb731 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -70,12 +70,49 @@ instance Show LlvmType where show (LMAlias (s,_)) = "%" ++ unpackFS s +-- | LLVM metadata values. Used for representing debug and optimization +-- information. +data LlvmMetaVal + -- | Metadata string + = MetaStr LMString + -- | Metadata node + | MetaNode LlvmMetaUnamed + -- | Normal value type as metadata + | MetaVar LlvmVar + deriving (Eq) + +-- | LLVM metadata nodes. +data LlvmMeta + -- | Unamed metadata + = MetaUnamed LlvmMetaUnamed [LlvmMetaVal] + -- | Named metadata + | MetaNamed LMString [LlvmMetaUnamed] + deriving (Eq) + +-- | Unamed metadata variable. +newtype LlvmMetaUnamed = LMMetaUnamed Int + +instance Eq LlvmMetaUnamed where + (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m + +instance Show LlvmMetaVal where + show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\"" + show (MetaNode n) = "metadata " ++ show n + show (MetaVar v) = show v + +instance Show LlvmMetaUnamed where + show (LMMetaUnamed u) = "!" ++ show u + +instance Show LlvmMeta where + show (MetaUnamed m _) = show m + show (MetaNamed m _) = "!" ++ unpackFS m + -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString type LMAlign = Maybe Int type LMConst = Bool -- ^ is a variable constant or not --- | Llvm Variables +-- | LLVM Variables data LlvmVar -- | Variables with a global scope. = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index f802fc414c..f239ee50cf 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -48,6 +48,7 @@ llvmCodeGen dflags h us cmms in do showPass dflags "LlVM CodeGen" bufh <- newBufHandle h + dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader Prt.bufLeftRender bufh $ pprLlvmHeader ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags env' <- {-# SCC "llvm_datas_gen" #-} diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index b8a44447fa..4309dcdae1 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -127,7 +127,7 @@ stmtToInstrs env stmt = case stmt of -> genCall env target res args ret -- Tail call - CmmJump arg -> genJump env arg + CmmJump arg live -> genJump env arg live -- CPS, only tail calls, no return's -- Actually, there are a few return statements that occur because of hand @@ -470,19 +470,19 @@ cmmPrimOpFunctions env mop -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData +genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) = do +genJump env (CmmLit (CmmLabel lbl)) live = do (env', vf, stmts, top) <- getHsFunc env lbl - (stgRegs, stgStmts) <- funEpilogue + (stgRegs, stgStmts) <- funEpilogue live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr = do +genJump env expr live = do let fty = llvmFunTy (env', vf, stmts, top) <- exprToVar env expr @@ -494,7 +494,7 @@ genJump env expr = do ++ show (ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue + (stgRegs, stgStmts) <- funEpilogue live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, @@ -550,7 +550,7 @@ genStore env addr@(CmmMachOp (MO_Sub _) [ = genStore_fast env addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val +genStore env addr val = genStore_slow env addr val [top] -- | CmmStore operation -- This is a special case for storing to a global register pointer @@ -558,8 +558,9 @@ genStore env addr val = genStore_slow env addr val genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr -> UniqSM StmtData genStore_fast env addr r n val - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -570,7 +571,7 @@ genStore_fast env addr r n val case pLower grt == getVarType vval of -- were fine True -> do - let s3 = Store vval ptr + let s3 = MetaStmt meta $ Store vval ptr return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -578,19 +579,19 @@ genStore_fast env addr r n val False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty - let s4 = Store vval ptr' + let s4 = MetaStmt meta $ Store vval ptr' return (env', stmts `snocOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val + False -> genStore_slow env addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData -genStore_slow env addr val = do +genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData +genStore_slow env addr val meta = do (env1, vaddr, stmts1, top1) <- exprToVar env addr (env2, vval, stmts2, top2) <- exprToVar env1 val @@ -599,17 +600,17 @@ genStore_slow env addr val = do -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty - let s2 = Store v vaddr + let s2 = MetaStmt meta $ Store v vaddr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do - let s1 = Store vval vaddr + let s1 = MetaStmt meta $ Store vval vaddr return (env2, stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty - let s2 = Store vval vptr + let s2 = MetaStmt meta $ Store vval vptr return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> @@ -841,8 +842,8 @@ genMachOp env opt op e = genMachOp_slow env opt op e genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] -> UniqSM ExprData genMachOp_fast env opt op r n e - = let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr + = let gr = lmGlobalRegVar r + grt = (pLower . getVarType) gr (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1031,7 +1032,7 @@ genLoad env e@(CmmMachOp (MO_Sub _) [ = genLoad_fast env e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty +genLoad env e ty = genLoad_slow env e ty [top] -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer @@ -1039,9 +1040,10 @@ genLoad env e ty = genLoad_slow env e ty genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType -> UniqSM ExprData genLoad_fast env e r n ty = - let gr = lmGlobalRegVar r - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty + let gr = lmGlobalRegVar r + meta = [getTBAA r] + grt = (pLower . getVarType) gr + ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits . pLower) grt `div` 8) in case isPointer grt && rem == 0 of True -> do @@ -1051,7 +1053,7 @@ genLoad_fast env e r n ty = case grt == ty' of -- were fine True -> do - (var, s3) <- doExpr ty' $ Load ptr + (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr) return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) @@ -1059,29 +1061,31 @@ genLoad_fast env e r n ty = False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty - (var, s4) <- doExpr ty' $ Load ptr' + (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr') return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty + False -> genLoad_slow env e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData -genLoad_slow env e ty = do +genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData +genLoad_slow env e ty meta = do (env', iptr, stmts, tops) <- exprToVar env e case getVarType iptr of LMPointer _ -> do - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load iptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load iptr) return (env', dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty - (dvar, load) <- doExpr (cmmToLlvmType ty) $ Load ptr + (dvar, load) <- doExpr (cmmToLlvmType ty) + (MetaExpr meta $ Load ptr) return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" @@ -1099,7 +1103,6 @@ genLoad_slow env e ty = do getCmmReg :: LlvmEnv -> CmmReg -> ExprData getCmmReg env r@(CmmLocal (LocalReg un _)) = let exists = varLookup un env - (newv, stmts) = allocReg r nenv = varInsert un (pLower $ getVarType newv) env in case exists of @@ -1197,15 +1200,29 @@ funPrologue = concat $ map getReg activeStgRegs -- | Function epilogue. Load STG variables to use as argument for call. -funEpilogue :: UniqSM ([LlvmVar], LlvmStatements) -funEpilogue = do - let loadExpr r = do - let reg = lmGlobalRegVar r +funEpilogue :: Maybe [GlobalReg] -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue Nothing = do + loads <- mapM loadExpr activeStgRegs + let (vars, stmts) = unzip loads + return (vars, concatOL stmts) + where + loadExpr r = do + let reg = lmGlobalRegVar r (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg return (v, unitOL s) + +funEpilogue (Just live) = do loads <- mapM loadExpr activeStgRegs let (vars, stmts) = unzip loads return (vars, concatOL stmts) + where + loadExpr r | r `elem` alwaysLive || r `elem` live = do + let reg = lmGlobalRegVar r + (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg + return (v, unitOL s) + loadExpr r = do + let ty = (pLower . getVarType $ lmGlobalRegVar r) + return (LMLitVar $ LMUndefLit ty, unitOL Nop) -- | A serries of statements to trash all the STG registers. diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index e0cebe5f21..187d1ecf03 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,6 +11,7 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data +import LlvmCodeGen.Regs import CLabel import OldCmm @@ -25,6 +26,16 @@ import Unique -- * Top level -- +-- | Header code for LLVM modules +pprLlvmHeader :: Doc +pprLlvmHeader = + moduleLayout + $+$ text "" + $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) + $+$ ppLlvmMetas stgTBAA + $+$ text "" + + -- | LLVM module layout description for the host target moduleLayout :: Doc moduleLayout = @@ -64,11 +75,6 @@ moduleLayout = #endif --- | Header code for LLVM modules -pprLlvmHeader :: Doc -pprLlvmHeader = - moduleLayout $+$ ppLlvmFunctionDecls (map snd ghcInternalFunctions) - -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> Doc pprLlvmData (globals, types) = diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index b0c63a4c34..55b2e0db80 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -3,7 +3,8 @@ -- module LlvmCodeGen.Regs ( - lmGlobalRegArg, lmGlobalRegVar + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, top, base, stack, heap, rx, tbaa, getTBAA ) where #include "HsVersions.h" @@ -11,8 +12,8 @@ module LlvmCodeGen.Regs ( import Llvm import CmmExpr -import Outputable ( panic ) import FastString +import Outputable ( panic ) -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: GlobalReg -> LlvmVar @@ -24,7 +25,7 @@ lmGlobalRegArg = lmGlobalReg "_Arg" {- Need to make sure the names here can't conflict with the unique generated names. Uniques generated names containing only base62 chars. So using say - the '_' char guarantees this. + the '_' char guarantees this. -} lmGlobalReg :: String -> GlobalReg -> LlvmVar lmGlobalReg suf reg @@ -49,9 +50,53 @@ lmGlobalReg suf reg DoubleReg 2 -> doubleGlobal $ "D2" ++ suf _other -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg) ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg where wordGlobal name = LMNLocalVar (fsLit name) llvmWord ptrGlobal name = LMNLocalVar (fsLit name) llvmWordPtr floatGlobal name = LMNLocalVar (fsLit name) LMFloat doubleGlobal name = LMNLocalVar (fsLit name) LMDouble +-- | A list of STG Registers that should always be considered alive +alwaysLive :: [GlobalReg] +alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] + +-- | STG Type Based Alias Analysis metadata +stgTBAA :: [LlvmMeta] +stgTBAA + = [ MetaUnamed topN [MetaStr (fsLit "top")] + , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN] + , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN] + , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN] + , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN] + ] + +-- | Id values +topN, stackN, heapN, rxN, baseN :: LlvmMetaUnamed +topN = LMMetaUnamed 0 +stackN = LMMetaUnamed 1 +heapN = LMMetaUnamed 2 +rxN = LMMetaUnamed 3 +baseN = LMMetaUnamed 4 + +-- | The various TBAA types +top, heap, stack, rx, base :: MetaData +top = (tbaa, topN) +heap = (tbaa, heapN) +stack = (tbaa, stackN) +rx = (tbaa, rxN) +base = (tbaa, baseN) + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> MetaData +getTBAA BaseReg = base +getTBAA Sp = stack +getTBAA Hp = heap +getTBAA (VanillaReg _ _) = rx +getTBAA _ = top + diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index c0301dc29b..148e11f65b 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -80,8 +80,7 @@ addErr :: Monad m => String -> EwM m () addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) - where w = "Warning: " ++ msg +addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc msg, ())) deprecate :: Monad m => String -> EwM m () deprecate s = do diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 1bd4fcef8a..48830e1b99 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -113,7 +113,7 @@ import Outputable #ifdef GHCI import Foreign.C ( CInt(..) ) #endif -import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage ) #ifdef GHCI import System.IO.Unsafe ( unsafePerformIO ) @@ -288,6 +288,7 @@ data DynFlag | Opt_GhciSandbox | Opt_GhciHistory | Opt_HelpfulErrors + | Opt_DeferTypeErrors -- temporary flags | Opt_RunCPS @@ -578,7 +579,7 @@ data DynFlags = DynFlags { -- flattenExtensionFlags language extensions extensionFlags :: IntSet, - -- | Message output action: use "ErrUtils" instead of this if you can + -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, haddockOptions :: Maybe String, @@ -921,7 +922,7 @@ defaultDynFlags mySettings = profAuto = NoProfAuto } -type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () +type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () defaultLogAction :: LogAction defaultLogAction severity srcSpan style msg @@ -930,7 +931,7 @@ defaultLogAction severity srcSpan style msg SevInfo -> printErrs msg style SevFatal -> printErrs msg style _ -> do hPutChar stderr '\n' - printErrs (mkLocMessage srcSpan msg) style + printErrs (mkLocMessage severity srcSpan msg) style -- careful (#2302): printErrs prints in UTF-8, whereas -- converting to string first and using hPutStr would -- just emit the low 8 bits of each unicode char. @@ -1326,7 +1327,7 @@ safeFlagCheck cmdl dflags = False | not cmdl && safeInferOn dflags && packageTrustOn dflags -> (dopt_unset dflags' Opt_PackageTrust, [L (pkgTrustOnLoc dflags') $ - "Warning: -fpackage-trust ignored;" ++ + "-fpackage-trust ignored;" ++ " must be specified with a Safe Haskell flag"] ) @@ -1349,8 +1350,8 @@ safeFlagCheck cmdl dflags = apFix f = if safeInferOn dflags then id else f - safeFailure loc str = [L loc $ "Warning: " ++ str ++ " is not allowed in" - ++ " Safe Haskell; ignoring " ++ str] + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, xopt Opt_GeneralizedNewtypeDeriving, @@ -1829,6 +1830,7 @@ fFlags = [ ( "ghci-sandbox", Opt_GhciSandbox, nop ), ( "ghci-history", Opt_GhciHistory, nop ), ( "helpful-errors", Opt_HelpfulErrors, nop ), + ( "defer-type-errors", Opt_DeferTypeErrors, nop ), ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ), ( "prof-count-entries", Opt_ProfCountEntries, nop ), diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index 1cce4ec633..6ba9df436c 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -6,15 +6,15 @@ \begin{code} module ErrUtils ( - Message, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, - Severity(..), - - ErrMsg, WarnMsg, - ErrorMessages, WarningMessages, + ErrMsg, WarnMsg, Severity(..), + Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - Messages, errorsFound, emptyMessages, + MsgDoc, mkLocMessage, printError, pprMessageBag, pprErrMsgBag, + pprLocErrMsg, makeIntoWarning, + + errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printBagOfErrors, printBagOfWarnings, + printBagOfErrors, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -36,6 +36,7 @@ module ErrUtils ( import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import Util import Outputable +import FastString import SrcLoc import DynFlags import StaticFlags ( opt_ErrorSpans ) @@ -51,10 +52,21 @@ import System.IO -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. -type Message = SDoc +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg -pprMessageBag :: Bag Message -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) +data ErrMsg = ErrMsg { + errMsgSpans :: [SrcSpan], + errMsgContext :: PrintUnqualified, + errMsgShortDoc :: MsgDoc, + errMsgExtraInfo :: MsgDoc, + errMsgSeverity :: Severity + } + -- The SrcSpan is used for sorting errors into line-number order + +type WarnMsg = ErrMsg +type MsgDoc = SDoc data Severity = SevOutput @@ -63,70 +75,56 @@ data Severity | SevError | SevFatal -mkLocMessage :: SrcSpan -> Message -> Message -mkLocMessage locn msg - | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg - | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg - -- always print the location, even if it is unhelpful. Error messages +instance Show ErrMsg where + show em = showSDoc (errMsgShortDoc em) + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". +mkLocMessage severity locn msg + | opt_ErrorSpans = hang (ppr locn <> colon <+> sev_info) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon <+> sev_info) 4 msg + where + sev_info = case severity of + SevWarning -> ptext (sLit "Warning:") + _other -> empty + -- For warnings, print Foo.hs:34: Warning: + -- <the warning message> -printError :: SrcSpan -> Message -> IO () -printError span msg = - printErrs (mkLocMessage span msg) defaultErrStyle +printError :: SrcSpan -> MsgDoc -> IO () +printError span msg = printErrs (mkLocMessage SevError span msg) defaultErrStyle +makeIntoWarning :: ErrMsg -> ErrMsg +makeIntoWarning err = err { errMsgSeverity = SevWarning } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -data ErrMsg = ErrMsg { - errMsgSpans :: [SrcSpan], - errMsgContext :: PrintUnqualified, - errMsgShortDoc :: Message, - errMsgExtraInfo :: Message - } - -- The SrcSpan is used for sorting errors into line-number order - -instance Show ErrMsg where - show em = showSDoc (errMsgShortDoc em) - -type WarnMsg = ErrMsg - --- A short (one-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg -mkErrMsg locn print_unqual msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- Variant that doesn't care about qualified/unqualified names -mkPlainErrMsg :: SrcSpan -> Message -> ErrMsg -mkPlainErrMsg locn msg - = ErrMsg { errMsgSpans = [locn], errMsgContext = alwaysQualify - , errMsgShortDoc = msg, errMsgExtraInfo = empty } - --- A long (multi-line) error message, with context to tell us whether --- to qualify names in the message or not. -mkLongErrMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongErrMsg locn print_unqual msg extra +mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg +mk_err_msg sev locn print_unqual msg extra = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual - , errMsgShortDoc = msg, errMsgExtraInfo = extra } - -mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg -mkWarnMsg = mkErrMsg - -mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> Message -> ErrMsg -mkLongWarnMsg = mkLongErrMsg - + , errMsgShortDoc = msg, errMsgExtraInfo = extra + , errMsgSeverity = sev } + +mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- A long (multi-line) error message +mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg -- Variant that doesn't care about qualified/unqualified names -mkPlainWarnMsg :: SrcSpan -> Message -> ErrMsg -mkPlainWarnMsg locn msg = mkWarnMsg locn alwaysQualify msg -type Messages = (Bag WarnMsg, Bag ErrMsg) - -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg +mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual msg extra +mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual msg empty +mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify msg empty +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual msg extra +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual msg empty +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify msg empty +---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) @@ -137,12 +135,8 @@ errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors = - printMsgBag dflags bag_of_errors SevError - -printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () -printBagOfWarnings dflags bag_of_warns = - printMsgBag dflags bag_of_warns SevWarning +printBagOfErrors dflags bag_of_errors + = printMsgBag dflags bag_of_errors pprErrMsgBag :: Bag ErrMsg -> [SDoc] pprErrMsgBag bag @@ -152,12 +146,23 @@ pprErrMsgBag bag errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] -printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () -printMsgBag dflags bag sev +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpans = spans + , errMsgShortDoc = d + , errMsgExtraInfo = e + , errMsgSeverity = sev + , errMsgContext = unqual }) + = withPprStyle (mkErrStyle unqual) (mkLocMessage sev s (d $$ e)) + where + (s : _) = spans -- Should be non-empty + +printMsgBag :: DynFlags -> Bag ErrMsg -> IO () +printMsgBag dflags bag = sequence_ [ let style = mkErrStyle unqual in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, + errMsgSeverity = sev, errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] @@ -293,22 +298,22 @@ ifVerbose dflags val act | verbosity dflags >= val = act | otherwise = return () -putMsg :: DynFlags -> Message -> IO () +putMsg :: DynFlags -> MsgDoc -> IO () putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg -putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO () +putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () putMsgWith dflags print_unqual msg = log_action dflags SevInfo noSrcSpan sty msg where sty = mkUserStyle print_unqual AllTheWay -errorMsg :: DynFlags -> Message -> IO () +errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg -fatalErrorMsg :: DynFlags -> Message -> IO () +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg -fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' :: LogAction -> MsgDoc -> IO () fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () @@ -319,7 +324,7 @@ showPass :: DynFlags -> String -> IO () showPass dflags what = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) -debugTraceMsg :: DynFlags -> Int -> Message -> IO () +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) \end{code} diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot index 08115a4b48..7718cbe2a6 100644 --- a/compiler/main/ErrUtils.lhs-boot +++ b/compiler/main/ErrUtils.lhs-boot @@ -11,8 +11,8 @@ data Severity | SevError | SevFatal -type Message = SDoc +type MsgDoc = SDoc -mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc \end{code} diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 9fad73a9f8..6322024c9e 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -123,7 +123,7 @@ mkPrelImports this_mod loc implicit_prelude import_decls ideclAs = Nothing, ideclHiding = Nothing } -parseError :: SrcSpan -> Message -> IO a +parseError :: SrcSpan -> MsgDoc -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 8c9e9a8f00..fc53d9d544 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -266,7 +266,7 @@ throwErrors = liftIO . throwIO . mkSrcErr -- failed, it must have been due to the warnings (i.e., @-Werror@). ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO $ ioA + ((warns,errs), mb_r) <- liftIO ioA logWarnings warns case mb_r of Nothing -> throwErrors errs @@ -844,8 +844,7 @@ hscFileFrontEnd mod_summary = do return tcg_env' where pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = text "Warning:" <+> quotes (pprMod t) - <+> text "has been infered as safe!" + errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" -------------------------------------------------------------- -- Safe Haskell @@ -1120,8 +1119,7 @@ wipeTrust tcg_env whyUnsafe = do where wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ text "Warning:" <+> quotes pprMod - <+> text "has been infered as unsafe!" + whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" , text "Reason:" , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 3eda19fba1..b6bf938332 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -238,12 +238,12 @@ printOrThrowWarnings dflags warns = when (not (isEmptyBag warns)) $ do throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg | otherwise - = printBagOfWarnings dflags warns + = printBagOfErrors dflags warns handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns = when (wopt Opt_WarnDeprecatedFlags dflags) $ do - -- It would be nicer if warns :: [Located Message], but that + -- It would be nicer if warns :: [Located MsgDoc], but that -- has circular import problems. let bag = listToBag [ mkPlainWarnMsg loc (text warn) | L loc warn <- warns ] diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index d7dc6bc764..d1fbe2f253 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -59,7 +59,7 @@ import Distribution.InstalledPackageInfo import Distribution.InstalledPackageInfo.Binary import Distribution.Package hiding (PackageId,depends) import FastString -import ErrUtils ( debugTraceMsg, putMsg, Message ) +import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception import System.Directory @@ -986,7 +986,7 @@ closeDeps :: PackageConfigMap -> IO [PackageId] closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) -throwErr :: MaybeErr Message a -> IO a +throwErr :: MaybeErr MsgDoc a -> IO a throwErr m = case m of Failed e -> ghcError (CmdLineError (showSDoc e)) Succeeded r -> return r @@ -994,7 +994,7 @@ throwErr m = case m of closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId -> [(PackageId,Maybe PackageId)] - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper @@ -1002,7 +1002,7 @@ add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) - -> MaybeErr Message [PackageId] + -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) | p `elem` ps = return ps -- Check if we've already added this package | otherwise = diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index 75b4d542a5..b46ca17f49 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -251,8 +251,8 @@ initSysTools mbMinusB ld_args = gcc_args -- We just assume on command line - ; let lc_prog = "llc" - lo_prog = "opt" + ; lc_prog <- getSetting "LLVM llc command" + ; lo_prog <- getSetting "LLVM opt command" ; return $ Settings { sTargetPlatform = Platform { diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index b404e87f31..02878bfff5 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -878,9 +878,9 @@ cmmStmtConFold stmt src' <- cmmExprConFold DataReference src return $ CmmStore addr' src' - CmmJump addr + CmmJump addr live -> do addr' <- cmmExprConFold JumpReference addr - return $ CmmJump addr' + return $ CmmJump addr' live CmmCall target regs args returns -> do target' <- case target of diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 8b96f7140a..7b704cbe8f 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -141,7 +141,7 @@ stmtToInstrs stmt = do CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg -> genJump arg + CmmJump arg _ -> genJump arg CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index 0022e043ee..4c295f11d5 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -141,7 +141,7 @@ stmtToInstrs stmt = case stmt of CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg -> genJump arg + CmmJump arg _ -> genJump arg CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index b7356ea3fd..c68519522d 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -166,7 +166,7 @@ stmtToInstrs stmt = do CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg -> genJump arg + CmmJump arg _ -> genJump arg CmmReturn -> panic "stmtToInstrs: return statement should have been cps'd away" diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 21984eced9..e0e97fed4a 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -145,7 +145,7 @@ haskell :- -- everywhere: skip whitespace and comments $white_no_nl+ ; -$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } +$tab+ { warn Opt_WarnTabs (text "Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out -- pragmas, "{-#", so that we don't accidentally treat them as comments. @@ -1484,7 +1484,7 @@ data ParseResult a SrcSpan -- The start and end of the text span related to -- the error. Might be used in environments which can -- show this span, e.g. by highlighting it. - Message -- The error message + MsgDoc -- The error message data PState = PState { buffer :: StringBuffer, @@ -1959,7 +1959,7 @@ getOffside = P $ \s@PState{last_loc=loc, context=stk} -> srcParseErr :: StringBuffer -- current buffer (placed just after the last token) -> Int -- length of the previous token - -> Message + -> MsgDoc srcParseErr buf len = hcat [ if null token then ptext (sLit "parse error (possibly incorrect indentation)") diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index d6793920a8..9803650842 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -480,9 +480,9 @@ export_subspec :: { Located ImpExpSubSpec } : {- empty -} { L0 ImpExpAbs } | '(' '..' ')' { LL ImpExpAll } | '(' ')' { LL (ImpExpList []) } - | '(' qcnames ')' { LL (ImpExpList $2) } + | '(' qcnames ')' { LL (ImpExpList (reverse $2)) } -qcnames :: { [RdrName] } +qcnames :: { [RdrName] } -- A reversed list : qcnames ',' qcname_ext { unLoc $3 : $1 } | qcname_ext { [unLoc $1] } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 39aee7d861..66db883d71 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -996,14 +996,14 @@ data ImpExpSubSpec = ImpExpAbs | ImpExpAll | ImpExpList [ RdrName ] mkModuleImpExp :: RdrName -> ImpExpSubSpec -> IE RdrName mkModuleImpExp name subs = case subs of - ImpExpAbs | isVarNameSpace (rdrNameSpace name) - -> IEVar name - ImpExpAbs -> IEThingAbs nameT - ImpExpAll -> IEThingAll nameT - ImpExpList xs -> IEThingWith nameT xs + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) -> IEVar name + | otherwise -> IEThingAbs nameT + ImpExpAll -> IEThingAll nameT + ImpExpList xs -> IEThingWith nameT xs where - nameT = setRdrNameSpace name tcClsName + nameT = setRdrNameSpace name tcClsName \end{code} ----------------------------------------------------------------------------- diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index c8a3a2ff25..8daa6fa3c7 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -253,12 +253,16 @@ basicKnownKeyNames -- Integer integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName, @@ -829,17 +833,23 @@ minusName = methName gHC_NUM (fsLit "-") minusClassOpKey negateName = methName gHC_NUM (fsLit "negate") negateClassOpKey integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, plusIntegerName, timesIntegerName, smallIntegerName, integerToWordName, integerToIntName, minusIntegerName, negateIntegerName, eqIntegerName, neqIntegerName, absIntegerName, signumIntegerName, leIntegerName, gtIntegerName, ltIntegerName, geIntegerName, compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, gcdIntegerName, lcmIntegerName, andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, shiftLIntegerName, shiftRIntegerName :: Name integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey +integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey +integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey @@ -858,6 +868,12 @@ geIntegerName = varQual gHC_INTEGER_TYPE (fsLit "geInteger") geI compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey +quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey +remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey +floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromIntegerName") floatFromIntegerIdKey +doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromIntegerName") doubleFromIntegerIdKey +encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatIntegerName") encodeFloatIntegerIdKey +encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleIntegerName") encodeDoubleIntegerIdKey gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey @@ -1470,11 +1486,15 @@ assertIdKey = mkPreludeMiscIdUnique 44 runSTRepIdKey = mkPreludeMiscIdUnique 45 mkIntegerIdKey, smallIntegerIdKey, integerToWordIdKey, integerToIntIdKey, + integerToWord64IdKey, integerToInt64IdKey, plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, negateIntegerIdKey, eqIntegerIdKey, neqIntegerIdKey, absIntegerIdKey, signumIntegerIdKey, leIntegerIdKey, gtIntegerIdKey, ltIntegerIdKey, geIntegerIdKey, compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, + floatFromIntegerIdKey, doubleFromIntegerIdKey, + encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, gcdIntegerIdKey, lcmIntegerIdKey, andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique @@ -1482,29 +1502,37 @@ mkIntegerIdKey = mkPreludeMiscIdUnique 60 smallIntegerIdKey = mkPreludeMiscIdUnique 61 integerToWordIdKey = mkPreludeMiscIdUnique 62 integerToIntIdKey = mkPreludeMiscIdUnique 63 -plusIntegerIdKey = mkPreludeMiscIdUnique 64 -timesIntegerIdKey = mkPreludeMiscIdUnique 65 -minusIntegerIdKey = mkPreludeMiscIdUnique 66 -negateIntegerIdKey = mkPreludeMiscIdUnique 67 -eqIntegerIdKey = mkPreludeMiscIdUnique 68 -neqIntegerIdKey = mkPreludeMiscIdUnique 69 -absIntegerIdKey = mkPreludeMiscIdUnique 70 -signumIntegerIdKey = mkPreludeMiscIdUnique 71 -leIntegerIdKey = mkPreludeMiscIdUnique 72 -gtIntegerIdKey = mkPreludeMiscIdUnique 73 -ltIntegerIdKey = mkPreludeMiscIdUnique 74 -geIntegerIdKey = mkPreludeMiscIdUnique 75 -compareIntegerIdKey = mkPreludeMiscIdUnique 76 -quotRemIntegerIdKey = mkPreludeMiscIdUnique 77 -divModIntegerIdKey = mkPreludeMiscIdUnique 78 -gcdIntegerIdKey = mkPreludeMiscIdUnique 79 -lcmIntegerIdKey = mkPreludeMiscIdUnique 80 -andIntegerIdKey = mkPreludeMiscIdUnique 81 -orIntegerIdKey = mkPreludeMiscIdUnique 82 -xorIntegerIdKey = mkPreludeMiscIdUnique 83 -complementIntegerIdKey = mkPreludeMiscIdUnique 84 -shiftLIntegerIdKey = mkPreludeMiscIdUnique 85 -shiftRIntegerIdKey = mkPreludeMiscIdUnique 86 +integerToWord64IdKey = mkPreludeMiscIdUnique 64 +integerToInt64IdKey = mkPreludeMiscIdUnique 65 +plusIntegerIdKey = mkPreludeMiscIdUnique 66 +timesIntegerIdKey = mkPreludeMiscIdUnique 67 +minusIntegerIdKey = mkPreludeMiscIdUnique 68 +negateIntegerIdKey = mkPreludeMiscIdUnique 69 +eqIntegerIdKey = mkPreludeMiscIdUnique 70 +neqIntegerIdKey = mkPreludeMiscIdUnique 71 +absIntegerIdKey = mkPreludeMiscIdUnique 72 +signumIntegerIdKey = mkPreludeMiscIdUnique 73 +leIntegerIdKey = mkPreludeMiscIdUnique 74 +gtIntegerIdKey = mkPreludeMiscIdUnique 75 +ltIntegerIdKey = mkPreludeMiscIdUnique 76 +geIntegerIdKey = mkPreludeMiscIdUnique 77 +compareIntegerIdKey = mkPreludeMiscIdUnique 78 +quotRemIntegerIdKey = mkPreludeMiscIdUnique 79 +divModIntegerIdKey = mkPreludeMiscIdUnique 80 +quotIntegerIdKey = mkPreludeMiscIdUnique 81 +remIntegerIdKey = mkPreludeMiscIdUnique 82 +floatFromIntegerIdKey = mkPreludeMiscIdUnique 83 +doubleFromIntegerIdKey = mkPreludeMiscIdUnique 84 +encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 85 +encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 86 +gcdIntegerIdKey = mkPreludeMiscIdUnique 87 +lcmIntegerIdKey = mkPreludeMiscIdUnique 88 +andIntegerIdKey = mkPreludeMiscIdUnique 89 +orIntegerIdKey = mkPreludeMiscIdUnique 90 +xorIntegerIdKey = mkPreludeMiscIdUnique 91 +complementIntegerIdKey = mkPreludeMiscIdUnique 92 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 93 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 94 rootMainKey, runMainKey :: Unique rootMainKey = mkPreludeMiscIdUnique 100 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index 40ee5b0850..fc0c20ad48 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -621,31 +621,44 @@ builtinRules builtinIntegerRules :: [CoreRule] builtinIntegerRules = - [rule_convert "integerToWord" integerToWordName mkWordLitWord, - rule_convert "integerToInt" integerToIntName mkIntLitInt, - rule_binop "plusInteger" plusIntegerName (+), - rule_binop "timesInteger" timesIntegerName (*), - rule_binop "minusInteger" minusIntegerName (-), - rule_unop "negateInteger" negateIntegerName negate, - rule_binop_Bool "eqInteger" eqIntegerName (==), - rule_binop_Bool "neqInteger" neqIntegerName (/=), - rule_unop "absInteger" absIntegerName abs, - rule_unop "signumInteger" signumIntegerName signum, - rule_binop_Bool "leInteger" leIntegerName (<=), - rule_binop_Bool "gtInteger" gtIntegerName (>), - rule_binop_Bool "ltInteger" ltIntegerName (<), - rule_binop_Bool "geInteger" geIntegerName (>=), - rule_binop_Ordering "compareInteger" compareIntegerName compare, - rule_divop "quotRemInteger" quotRemIntegerName quotRem, - rule_divop "divModInteger" divModIntegerName divMod, - rule_binop "gcdInteger" gcdIntegerName gcd, - rule_binop "lcmInteger" lcmIntegerName lcm, - rule_binop "andInteger" andIntegerName (.&.), - rule_binop "orInteger" orIntegerName (.|.), - rule_binop "xorInteger" xorIntegerName xor, - rule_unop "complementInteger" complementIntegerName complement, - rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, - rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] + [-- TODO: smallInteger rule + -- TODO: wordToInteger rule + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + rule_convert "integerToWord64" integerToWord64Name mkWord64LitWord64, + -- TODO: word64ToInteger rule + rule_convert "integerToInt64" integerToInt64Name mkInt64LitInt64, + -- TODO: int64ToInteger rule + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Bool "eqInteger" eqIntegerName (==), + rule_binop_Bool "neqInteger" neqIntegerName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Bool "leInteger" leIntegerName (<=), + rule_binop_Bool "gtInteger" gtIntegerName (>), + rule_binop_Bool "ltInteger" ltIntegerName (<), + rule_binop_Bool "geInteger" geIntegerName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName mkFloatLitFloat, + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, + -- TODO: decodeDoubleInteger rule + rule_convert "doubleFromInteger" doubleFromIntegerName mkDoubleLitDouble, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_Int_binop "shiftLInteger" shiftLIntegerName shiftL, + rule_Int_binop "shiftRInteger" shiftRIntegerName shiftR] where rule_convert str name convert = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, ru_try = match_Integer_convert convert } @@ -655,9 +668,12 @@ builtinIntegerRules = rule_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop op } - rule_divop str name op + rule_divop_both str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, - ru_try = match_Integer_divop op } + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } rule_Int_binop str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_Int_binop op } @@ -667,6 +683,9 @@ builtinIntegerRules = rule_binop_Ordering str name op = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, ru_try = match_Integer_binop_Ordering op } + rule_encodeFloat str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_encodeFloat op } --------------------------------------------------- -- The rule is this: @@ -737,7 +756,7 @@ match_Integer_convert :: Num a -> Maybe (Expr CoreBndr) match_Integer_convert convert id_unf [xl] | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl - = Just (convert (fromIntegral x)) + = Just (convert (fromInteger x)) match_Integer_convert _ _ _ = Nothing match_Integer_unop :: (Integer -> Integer) @@ -760,11 +779,11 @@ match_Integer_binop binop id_unf [xl,yl] match_Integer_binop _ _ _ = Nothing -- This helper is used for the quotRem and divMod functions -match_Integer_divop :: (Integer -> Integer -> (Integer, Integer)) - -> IdUnfoldingFun - -> [Expr CoreBndr] - -> Maybe (Expr CoreBndr) -match_Integer_divop divop id_unf [xl,yl] +match_Integer_divop_both :: (Integer -> Integer -> (Integer, Integer)) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_both divop id_unf [xl,yl] | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl , y /= 0 @@ -776,9 +795,20 @@ match_Integer_divop divop id_unf [xl,yl] Type integerTy, Lit (LitInteger r i), Lit (LitInteger s i)] - _ -> panic "match_Integer_divop: mkIntegerId has the wrong type" + _ -> panic "match_Integer_divop_both: mkIntegerId has the wrong type" +match_Integer_divop_both _ _ _ = Nothing -match_Integer_divop _ _ _ = Nothing +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_divop_one divop id_unf [xl,yl] + | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (LitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ = Nothing match_Integer_Int_binop :: (Integer -> Int -> Integer) -> IdUnfoldingFun @@ -812,4 +842,15 @@ match_Integer_binop_Ordering binop id_unf [xl, yl] EQ -> eqVal GT -> gtVal match_Integer_binop_Ordering _ _ _ = Nothing + +match_Integer_Int_encodeFloat :: RealFloat a + => (a -> Expr CoreBndr) + -> IdUnfoldingFun + -> [Expr CoreBndr] + -> Maybe (Expr CoreBndr) +match_Integer_Int_encodeFloat mkLit id_unf [xl,yl] + | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (MachInt y) <- exprIsLiteral_maybe id_unf yl + = Just (mkLit $ encodeFloat x (fromInteger y)) +match_Integer_Int_encodeFloat _ _ _ = Nothing \end{code} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index ccce0c9caf..a4bf1f2d69 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -63,7 +63,7 @@ import Module ( ModuleName, moduleName ) import UniqFM import DataCon ( dataConFieldLabels ) import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) -import ErrUtils ( Message ) +import ErrUtils ( MsgDoc ) import SrcLoc import Outputable import Util @@ -672,7 +672,7 @@ lookupSigOccRn ctxt sig lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either Message Name) + -> RdrName -> RnM (Either MsgDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index a09509754e..1f9041e473 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -725,9 +725,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] + lookup_ie :: Bool -> IE RdrName -> MaybeErr MsgDoc [(IE Name,AvailInfo)] lookup_ie opt_typeFamilies ie - = let bad_ie :: MaybeErr Message a + = let bad_ie :: MaybeErr MsgDoc a bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails) lookup_name rdr @@ -1680,7 +1680,7 @@ typeItemErr name wherestr ptext (sLit "Use -XTypeFamilies to enable this extension") ] exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName - -> Message + -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon , ppr_export ie1' name1' diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index c82a5577c6..829c2ca40f 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -184,7 +184,7 @@ lintPassResult dflags pass binds ; displayLintResults dflags pass warns errs binds } displayLintResults :: DynFlags -> CoreToDo - -> Bag Err.Message -> Bag Err.Message -> CoreProgram + -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram -> IO () displayLintResults dflags pass warns errs binds | not (isEmptyBag errs) diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index d1c4ae3ad9..be0205f323 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -17,7 +17,7 @@ import PrimOp ( primOpType ) import Literal ( literalType ) import Maybes import Name ( getSrcLoc ) -import ErrUtils ( Message, mkLocMessage ) +import ErrUtils ( MsgDoc, Severity(..), mkLocMessage ) import TypeRep import Type import TyCon @@ -281,8 +281,8 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs) = do newtype LintM a = LintM { unLintM :: [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag Message -- Error messages so far - -> (a, Bag Message) -- Result and error messages (if any) + -> Bag MsgDoc -- Error messages so far + -> (a, Bag MsgDoc) -- Result and error messages (if any) } data LintLocInfo @@ -309,7 +309,7 @@ pp_binders bs \end{code} \begin{code} -initL :: LintM a -> Maybe Message +initL :: LintM a -> Maybe MsgDoc initL (LintM m) = case (m [] emptyVarSet emptyBag) of { (_, errs) -> if isEmptyBag errs then @@ -335,19 +335,19 @@ thenL_ m k = LintM $ \loc scope errs \end{code} \begin{code} -checkL :: Bool -> Message -> LintM () +checkL :: Bool -> MsgDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg -addErrL :: Message -> LintM () +addErrL :: MsgDoc -> LintM () addErrL msg = LintM $ \loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message +addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage l (hdr $$ msg) + in mkLocMessage SevWarning l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a @@ -380,7 +380,7 @@ have long since disappeared. \begin{code} checkFunApp :: Type -- The function type -> [Type] -- The arg type(s) - -> Message -- Error message + -> MsgDoc -- Error message -> LintM (Maybe Type) -- Just ty => result type is accurate checkFunApp fun_ty arg_tys msg @@ -391,8 +391,8 @@ checkFunApp fun_ty arg_tys msg where (mb_ty, mb_msg) = cfa True fun_ty arg_tys - cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? - , Maybe Message) -- Errors? + cfa :: Bool -> Type -> [Type] -> (Maybe Type -- Accurate result? + , Maybe MsgDoc) -- Errors? cfa accurate fun_ty [] -- Args have run out; that's fine = (if accurate then Just fun_ty else Nothing, Nothing) @@ -461,7 +461,7 @@ checkInScope id = LintM $ \loc scope errs else ((), errs) -checkTys :: Type -> Type -> Message -> LintM () +checkTys :: Type -> Type -> MsgDoc -> LintM () checkTys ty1 ty2 msg = LintM $ \loc _scope errs -> if (ty1 `stgEqType` ty2) then ((), errs) @@ -469,35 +469,35 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs \end{code} \begin{code} -_mkCaseAltMsg :: [StgAlt] -> Message +_mkCaseAltMsg :: [StgAlt] -> MsgDoc _mkCaseAltMsg _alts = ($$) (text "In some case alternatives, type of alternatives not all same:") (empty) -- LATER: ppr alts -mkDefltMsg :: Id -> TyCon -> Message +mkDefltMsg :: Id -> TyCon -> MsgDoc mkDefltMsg bndr tc = ($$) (ptext (sLit "Binder of a case expression doesn't match type of scrutinee:")) (ppr bndr $$ ppr (idType bndr) $$ ppr tc) -mkFunAppMsg :: Type -> [Type] -> StgExpr -> Message +mkFunAppMsg :: Type -> [Type] -> StgExpr -> MsgDoc mkFunAppMsg fun_ty arg_tys expr = vcat [text "In a function application, function type doesn't match arg types:", hang (ptext (sLit "Function type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys)), hang (ptext (sLit "Expression:")) 4 (ppr expr)] -mkRhsConMsg :: Type -> [Type] -> Message +mkRhsConMsg :: Type -> [Type] -> MsgDoc mkRhsConMsg fun_ty arg_tys = vcat [text "In a RHS constructor application, con type doesn't match arg types:", hang (ptext (sLit "Constructor type:")) 4 (ppr fun_ty), hang (ptext (sLit "Arg types:")) 4 (vcat (map (ppr) arg_tys))] -mkAltMsg1 :: Type -> Message +mkAltMsg1 :: Type -> MsgDoc mkAltMsg1 ty = ($$) (text "In a case expression, type of scrutinee does not match patterns") (ppr ty) -mkAlgAltMsg2 :: Type -> DataCon -> Message +mkAlgAltMsg2 :: Type -> DataCon -> MsgDoc mkAlgAltMsg2 ty con = vcat [ text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:", @@ -505,7 +505,7 @@ mkAlgAltMsg2 ty con ppr con ] -mkAlgAltMsg3 :: DataCon -> [Id] -> Message +mkAlgAltMsg3 :: DataCon -> [Id] -> MsgDoc mkAlgAltMsg3 con alts = vcat [ text "In some algebraic case alternative, number of arguments doesn't match constructor:", @@ -513,7 +513,7 @@ mkAlgAltMsg3 con alts ppr alts ] -mkAlgAltMsg4 :: Type -> Id -> Message +mkAlgAltMsg4 :: Type -> Id -> MsgDoc mkAlgAltMsg4 ty arg = vcat [ text "In some algebraic case alternative, type of argument doesn't match data constructor:", @@ -521,7 +521,7 @@ mkAlgAltMsg4 ty arg ppr arg ] -_mkRhsMsg :: Id -> Type -> Message +_mkRhsMsg :: Id -> Type -> MsgDoc _mkRhsMsg binder ty = vcat [hsep [ptext (sLit "The type of this binder doesn't match the type of its RHS:"), ppr binder], diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 09ea2dfab4..b589c265db 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -27,14 +27,12 @@ module Inst ( -- Simple functions over evidence variables hasEqualities, unitImplication, - tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVarXs, tyVarsOfEvVarX, + tyVarsOfWC, tyVarsOfBag, tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDict, tyVarsOfCDicts, - tidyWantedEvVar, tidyWantedEvVars, tidyWC, - tidyEvVar, tidyImplication, tidyCt, + tidyEvVar, tidyCt, tidyGivenLoc, - substWantedEvVar, substWantedEvVars, substEvVar, substImplication, substCt ) where @@ -87,7 +85,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkEvVarX ev loc) + ; emitFlat (mkNonCanonical ev (Wanted loc)) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -550,13 +548,7 @@ tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) tyVarsOfImplication :: Implication -> TyVarSet tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted }) - = tyVarsOfWC wanted `minusVarSet` skols - -tyVarsOfEvVarX :: EvVarX a -> TyVarSet -tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev - -tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet -tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX + = tyVarsOfWC wanted `delVarSetList` skols tyVarsOfEvVar :: EvVar -> TyVarSet tyVarsOfEvVar ev = tyVarsOfType $ evVarPred ev @@ -576,34 +568,9 @@ tidyCt env ct , cc_flavor = tidyFlavor env (cc_flavor ct) , cc_depth = cc_depth ct } -tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints -tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) - = WC { wc_flat = mapBag (tidyCt env) flat - , wc_impl = mapBag (tidyImplication env) implic - , wc_insol = mapBag (tidyCt env) insol } - -tidyImplication :: TidyEnv -> Implication -> Implication -tidyImplication env implic@(Implic { ic_skols = tvs - , ic_given = given - , ic_wanted = wanted - , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' - , ic_given = map (tidyEvVar env1) given - , ic_wanted = tidyWC env1 wanted - , ic_loc = tidyGivenLoc env1 loc } - where - (env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs) - tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar -tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l - -tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar -tidyWantedEvVars env = mapBag (tidyWantedEvVar env) - - tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk tidyFlavor _ fl = fl @@ -614,6 +581,14 @@ tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span c tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) +tidySkolemInfo env (UnifyForAllSkol skol_tvs ty) + = UnifyForAllSkol (map tidy_tv skol_tvs) (tidyType env ty) + where + tidy_tv tv = case getTyVar_maybe ty' of + Just tv' -> tv' + Nothing -> pprPanic "ticySkolemInfo" (ppr tv <+> ppr ty') + where + ty' = tidyTyVarOcc env tv tidySkolemInfo _ info = info ---------------- Substitution ------------------------- @@ -641,23 +616,16 @@ substImplication subst implic@(Implic { ic_skols = tvs , ic_given = given , ic_wanted = wanted , ic_loc = loc }) - = implic { ic_skols = mkVarSet tvs' + = implic { ic_skols = tvs' , ic_given = map (substEvVar subst1) given , ic_wanted = substWC subst1 wanted , ic_loc = substGivenLoc subst1 loc } where - (subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs) + (subst1, tvs') = mapAccumL substTyVarBndr subst tvs substEvVar :: TvSubst -> EvVar -> EvVar substEvVar subst var = setVarType var (substTy subst (varType var)) -substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar -substWantedEvVars subst = mapBag (substWantedEvVar subst) - -substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar -substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l - - substFlavor :: TvSubst -> CtFlavor -> CtFlavor substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk substFlavor _ fl = fl diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index ac826b7507..7d20aaa946 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -130,7 +130,7 @@ tcHsBootSigs (ValBindsOut binds sigs) tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) -badBootDeclErr :: Message +badBootDeclErr :: MsgDoc badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file") ------------------------ @@ -739,7 +739,7 @@ tcVect (HsVectInstOut _) vectCtxt :: Outputable thing => thing -> SDoc vectCtxt thing = ptext (sLit "When checking the vectorisation declaration for") <+> ppr thing -scalarTyConMustBeNullary :: Message +scalarTyConMustBeNullary :: MsgDoc scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary") -------------- diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 237f73d1e3..2e87aa5d77 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -738,7 +738,7 @@ flatten d ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (tvs, rho) = splitForAllTys ty - ; when (under_families tvs rho) $ flattenForAllErrorTcS ctxt ty + ; when (under_families tvs rho) $ wrapErrTcS $ flattenForAllErrorTcS ctxt ty ; (rho', co) <- flatten d ctxt rho ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } @@ -821,26 +821,6 @@ canEq _d fl eqv ty1 ty2 do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () } ; return Stop } --- Split up an equality between function types into two equalities. -canEq d fl eqv (FunTy s1 t1) (FunTy s2 t2) - = do { argeqv <- newEqVar fl s1 s2 - ; reseqv <- newEqVar fl t1 t2 - ; let argeqv_v = evc_the_evvar argeqv - reseqv_v = evc_the_evvar reseqv - ; (fl1,fl2) <- case fl of - Wanted {} -> - do { _ <- setEqBind eqv (mkTcFunCo (mkTcCoVarCo argeqv_v) (mkTcCoVarCo reseqv_v)) fl - ; return (fl,fl) } - Given {} -> - do { fl1 <- setEqBind argeqv_v (mkTcNthCo 0 (mkTcCoVarCo eqv)) fl - ; fl2 <- setEqBind reseqv_v (mkTcNthCo 1 (mkTcCoVarCo eqv)) fl - ; return (fl1,fl2) - } - Derived {} -> - return (fl,fl) - - ; canEqEvVarsCreated d [fl2,fl1] [reseqv,argeqv] [t1,s1] [t2,s2] } - -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ @@ -849,6 +829,11 @@ canEq d fl eqv ty1@(TyVarTy {}) ty2 canEq d fl eqv ty1 ty2@(TyVarTy {}) = canEqLeaf d fl eqv ty1 ty2 +-- See Note [Naked given applications] +canEq d fl eqv ty1 ty2 + | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 + | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' + canEq d fl eqv ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 @@ -856,14 +841,18 @@ canEq d fl eqv ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - , tc1 == tc2 - , length tys1 == length tys2 +canEq d fl eqv ty1 ty2 + | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 + , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 + , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 = -- Generate equalities for each of the corresponding arguments - do { let (kis1, tys1') = span isKind tys1 + if (tc1 /= tc2 || length tys1 /= length tys2) + -- Fail straight away for better error messages + then canEqFailure d fl eqv + else do { + let (kis1, tys1') = span isKind tys1 (_kis2, tys2') = span isKind tys2 - ; let kicos = map mkTcReflCo kis1 + kicos = map mkTcReflCo kis1 ; argeqvs <- zipWithM (newEqVar fl) tys1' tys2' ; fls <- case fl of @@ -881,16 +870,32 @@ canEq d fl eqv (TyConApp tc1 tys1) (TyConApp tc2 tys2) -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq d fl eqv ty1 ty2 - | Nothing <- tcView ty1 -- Naked applications ONLY - , Nothing <- tcView ty2 -- See Note [Naked given applications] - , Just (s1,t1) <- tcSplitAppTy_maybe ty1 +canEq d fl eqv ty1 ty2 -- e.g. F a b ~ Maybe c + -- where F has arity 1 + | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 + = canEqAppTy d fl eqv s1 t1 s2 t2 + +canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) + | tcIsForAllTy s1, tcIsForAllTy s2, + Wanted {} <- fl + = canEqFailure d fl eqv + | otherwise + = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) + ; return Stop } + +canEq d fl eqv _ _ = canEqFailure d fl eqv + +-- Type application +canEqAppTy :: SubGoalDepth + -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type + -> TcS StopOrContinue +canEqAppTy d fl eqv s1 t1 s2 t2 = ASSERT( not (isKind t1) && not (isKind t2) ) if isGivenOrSolved fl then - do { traceTcS "canEq/(app case)" $ + do { traceTcS "canEq (app case)" $ text "Ommitting decomposition of given equality between: " - <+> ppr ty1 <+> text "and" <+> ppr ty2 + <+> ppr (AppTy s1 t1) <+> text "and" <+> ppr (AppTy s2 t2) -- We cannot decompose given applications -- because we no longer have 'left' and 'right' ; return Stop } @@ -906,25 +911,30 @@ canEq d fl eqv ty1 ty2 ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } - -canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) - | tcIsForAllTy s1, tcIsForAllTy s2, - Wanted {} <- fl - = canEqFailure d fl eqv - | otherwise - = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) - ; return Stop } - --- Finally expand any type synonym applications. -canEq d fl eqv ty1 ty2 | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 -canEq d fl eqv ty1 ty2 | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' -canEq d fl eqv _ _ = canEqFailure d fl eqv - canEqFailure :: SubGoalDepth -> CtFlavor -> EvVar -> TcS StopOrContinue -canEqFailure d fl eqv = do { emitFrozenError fl eqv d; return Stop } +canEqFailure d fl eqv + = do { when (isWanted fl) (delCachedEvVar eqv fl) + -- See Note [Combining insoluble constraints] + ; emitFrozenError fl eqv d + ; return Stop } \end{code} +Note [Combining insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As this point we have an insoluble constraint, like Int~Bool. + + * If it is Wanted, delete it from the cache, so that subsequent + Int~Bool constraints give rise to separate error messages + + * But if it is Derived, DO NOT delete from cache. A class constraint + may get kicked out of the inert set, and then have its functional + dependency Derived constraints generated a second time. In that + case we don't want to get two (or more) error messages by + generating two (or more) insoluble fundep constraints from the same + class constraint. + + Note [Naked given applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider: diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index ba77be5f4d..dda82fff99 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1516,25 +1516,25 @@ genDerivStuff loc fix_env clas name tycon %************************************************************************ \begin{code} -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> MsgDoc derivingKindErr tc cls cls_tys cls_kind = hang (ptext (sLit "Cannot derive well-kinded instance of form") <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "...")))) 2 (ptext (sLit "Class") <+> quotes (ppr cls) <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> Message +derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc derivingEtaErr cls cls_tys inst_ty = sep [ptext (sLit "Cannot eta-reduce to an instance of form"), nest 2 (ptext (sLit "instance (...) =>") <+> pprClassPred cls (cls_tys ++ [inst_ty]))] -typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message +typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> MsgDoc typeFamilyPapErr tc cls cls_tys inst_ty = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty]))) 2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc) -derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message +derivingThingErr :: Bool -> Class -> [Type] -> Type -> MsgDoc -> MsgDoc derivingThingErr newtype_deriving clas tys ty why = sep [(hang (ptext (sLit "Can't make a derived instance of")) 2 (quotes (ppr pred)) @@ -1554,7 +1554,7 @@ standaloneCtxt :: LHsType Name -> SDoc standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: PredType -> Message +derivInstCtxt :: PredType -> MsgDoc derivInstCtxt pred = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) \end{code} diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 476ad6e84b..a6aef315ab 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and @@ -7,9 +8,10 @@ -- for details module TcErrors( - reportUnsolved, + reportUnsolved, ErrEnv, warnDefaulting, unifyCtxt, + misMatchMsg, flattenForAllErrorTcS, solverDepthErrorTcS @@ -19,33 +21,31 @@ module TcErrors( import TcRnMonad import TcMType -import TcSMonad import TcType import TypeRep import Type import Kind ( isKind ) -import Class -import Unify ( tcMatchTys ) +import Unify ( tcMatchTys ) import Inst import InstEnv import TyCon +import TcEvidence import Name import NameEnv -import Id ( idType ) +import Id ( idType ) import Var import VarSet import VarEnv -import SrcLoc import Bag -import BasicTypes ( IPName ) -import ListSetOps( equivClasses ) -import Maybes( mapCatMaybes ) +import Maybes +import ErrUtils ( ErrMsg, makeIntoWarning, pprLocErrMsg ) import Util import FastString import Outputable import DynFlags -import Data.List( partition ) -import Control.Monad( when, unless, filterM ) +import Data.List ( partition, mapAccumL ) +import Data.Either ( partitionEithers ) +-- import Control.Monad ( when ) \end{code} %************************************************************************ @@ -59,26 +59,40 @@ from the insts, or just whatever seems to be around in the monad just now? \begin{code} -reportUnsolved :: WantedConstraints -> TcM () -reportUnsolved wanted +-- We keep an environment mapping coercion ids to the error messages they +-- trigger; this is handy for -fwarn--type-errors +type ErrEnv = VarEnv [ErrMsg] + +reportUnsolved :: Bool -> WantedConstraints -> TcM (Bag EvBind) +reportUnsolved runtimeCoercionErrors wanted | isEmptyWC wanted - = return () + = return emptyBag | otherwise = do { -- Zonk to un-flatten any flatten-skols - ; wanted <- zonkWC wanted + wanted <- zonkWC wanted ; env0 <- tcInitTidyEnv + ; defer <- if runtimeCoercionErrors + then do { ev <- newTcEvBinds + ; return (Just ev) } + else return Nothing + + ; errs_so_far <- ifErrsM (return True) (return False) ; let tidy_env = tidyFreeTyVars env0 free_tvs free_tvs = tyVarsOfWC wanted err_ctxt = CEC { cec_encl = [] - , cec_insol = insolubleWC wanted + , cec_insol = errs_so_far , cec_extra = empty - , cec_tidy = tidy_env } - tidy_wanted = tidyWC tidy_env wanted + , cec_tidy = tidy_env + , cec_defer = defer } + + ; traceTc "reportUnsolved" (ppr free_tvs $$ ppr wanted) - ; traceTc "reportUnsolved" (ppr tidy_wanted) + ; reportWanteds err_ctxt wanted - ; reportTidyWanteds err_ctxt tidy_wanted } + ; case defer of + Nothing -> return emptyBag + Just ev -> getTcEvBinds ev } -------------------------------------------- -- Internal functions @@ -87,175 +101,265 @@ reportUnsolved wanted data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) + -- ic_skols and givens are tidied, rest are not , cec_tidy :: TidyEnv , cec_extra :: SDoc -- Add this to each error message - , cec_insol :: Bool -- True <=> we are reporting insoluble errors only - -- Main effect: don't say "Cannot deduce..." - -- when reporting equality errors; see misMatchOrCND + , cec_insol :: Bool -- True <=> do not report errors involving + -- ambiguous errors + , cec_defer :: Maybe EvBindsVar + -- Nothinng <=> errors are, well, errors + -- Just ev <=> make errors into warnings, and emit evidence + -- bindings into 'ev' for unsolved constraints } -reportTidyImplic :: ReportErrCtxt -> Implication -> TcM () -reportTidyImplic ctxt implic - | BracketSkol <- ctLocOrigin (ic_loc implic) - , not insoluble -- For Template Haskell brackets report only - = return () -- definite errors. The whole thing will be re-checked - -- later when we plug it in, and meanwhile there may - -- certainly be un-satisfied constraints +reportImplic :: ReportErrCtxt -> Implication -> TcM () +reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_given = given + , ic_wanted = wanted, ic_binds = evb + , ic_insol = insoluble, ic_loc = loc }) + | BracketSkol <- ctLocOrigin loc + , not insoluble -- For Template Haskell brackets report only + = return () -- definite errors. The whole thing will be re-checked + -- later when we plug it in, and meanwhile there may + -- certainly be un-satisfied constraints | otherwise - = reportTidyWanteds ctxt' (ic_wanted implic) + = reportWanteds ctxt' wanted where - insoluble = ic_insol implic - ctxt' = ctxt { cec_encl = implic : cec_encl ctxt - , cec_insol = insoluble } - -reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () -reportTidyWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) - | cec_insol ctxt -- If there are any insolubles, report only them - -- because they are unconditionally wrong - -- Moreover, if any of the insolubles are givens, stop right there - -- ignoring nested errors, because the code is inaccessible - = do { let (given, other) = partitionBag (isGivenOrSolved . cc_flavor) insols - insol_implics = filterBag ic_insol implics - ; if isEmptyBag given - then do { mapBagM_ (reportInsoluble ctxt) other - ; mapBagM_ (reportTidyImplic ctxt) insol_implics } - else mapBagM_ (reportInsoluble ctxt) given } - - | otherwise -- No insoluble ones - = ASSERT( isEmptyBag insols ) - do { let flat_evs = bagToList $ mapBag to_wev flats - to_wev ct | Wanted wl <- cc_flavor ct = mkEvVarX (cc_id ct) wl - | otherwise = panic "reportTidyWanteds: unsolved is not wanted!" - (ambigs, non_ambigs) = partition is_ambiguous flat_evs - (tv_eqs, others) = partitionWith is_tv_eq non_ambigs - - ; groupErrs (reportEqErrs ctxt) tv_eqs - ; when (null tv_eqs) $ groupErrs (reportFlat ctxt) others - ; mapBagM_ (reportTidyImplic ctxt) implics - - -- Only report ambiguity if no other errors (at all) happened - -- See Note [Avoiding spurious errors] in TcSimplify - ; ifErrsM (return ()) $ reportAmbigErrs ctxt ambigs } + (env1, tvs') = mapAccumL tidyTyVarBndr (cec_tidy ctxt) tvs + implic' = implic { ic_skols = tvs' + , ic_given = map (tidyEvVar env1) given + , ic_loc = tidyGivenLoc env1 loc } + ctxt' = ctxt { cec_tidy = env1 + , cec_encl = implic' : cec_encl ctxt + , cec_defer = case cec_defer ctxt of + Nothing -> Nothing + Just {} -> Just evb } + +reportWanteds :: ReportErrCtxt -> WantedConstraints -> TcM () +reportWanteds ctxt (WC { wc_flat = flats, wc_insol = insols, wc_impl = implics }) + = reportTidyWanteds ctxt tidy_insols tidy_flats implics where - -- Report equalities of form (a~ty) first. They are usually - -- skolem-equalities, and they cause confusing knock-on - -- effects in other errors; see test T4093b. - is_tv_eq c | Just (ty1, ty2) <- getEqPredTys_maybe (evVarOfPred c) - , tcIsTyVarTy ty1 || tcIsTyVarTy ty2 - = Left (c, (ty1, ty2)) - | otherwise - = Right (c, evVarOfPred c) - - -- Treat it as "ambiguous" if - -- (a) it is a class constraint - -- (b) it constrains only type variables - -- (else we'd prefer to report it as "no instance for...") - -- (c) it mentions a (presumably un-filled-in) meta type variable - is_ambiguous d = isTyVarClassPred pred - && any isAmbiguousTyVar (varSetElems (tyVarsOfType pred)) - where - pred = evVarOfPred d - -reportInsoluble :: ReportErrCtxt -> Ct -> TcM () --- Precondition: insolubles are always NonCanonicals! -reportInsoluble ctxt ct - | ev <- cc_id ct - , flav <- cc_flavor ct - , Just (ty1, ty2) <- getEqPredTys_maybe (evVarPred ev) - = setCtFlavorLoc flav $ - do { let ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg } - ; reportEqErr ctxt2 ty1 ty2 } + env = cec_tidy ctxt + tidy_insols = mapBag (tidyCt env) insols + tidy_flats = mapBag (tidyCt env) flats + +reportTidyWanteds :: ReportErrCtxt -> Bag Ct -> Bag Ct -> Bag Implication -> TcM () +reportTidyWanteds ctxt insols flats implics + | Just ev_binds_var <- cec_defer ctxt + = do { -- Defer errors to runtime + -- See Note [Deferring coercion errors to runtime] in TcSimplify + mapBagM_ (deferToRuntime ev_binds_var ctxt mkFlatErr) + (flats `unionBags` insols) + ; mapBagM_ (reportImplic ctxt) implics } + | otherwise - = pprPanic "reportInsoluble" (pprEvVarWithType (cc_id ct)) + = do { reportInsolsAndFlats ctxt insols flats + ; mapBagM_ (reportImplic ctxt) implics } + + +deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) + -> Ct -> TcM () +deferToRuntime ev_binds_var ctxt mk_err_msg ct + | Wanted loc <- cc_flavor ct + = do { err <- setCtLoc loc $ + mk_err_msg ctxt ct + ; let ev_id = cc_id ct + err_msg = pprLocErrMsg err + err_fs = mkFastString $ showSDoc $ + err_msg $$ text "(deferred type error)" + + -- Create the binding + ; addTcEvBind ev_binds_var ev_id (EvDelayedError (idType ev_id) err_fs) + + -- And emit a warning + ; reportWarning (makeIntoWarning err) } + + | otherwise -- Do not set any evidence for Given/Derived + = return () + +reportInsolsAndFlats :: ReportErrCtxt -> Cts -> Cts -> TcM () +reportInsolsAndFlats ctxt insols flats + = tryReporters + [ -- First deal with things that are utterly wrong + -- Like Int ~ Bool (incl nullary TyCons) + -- or Int ~ t a (AppTy on one side) + ("Utterly wrong", utterly_wrong, groupErrs (mkEqErr ctxt)) + + -- Report equalities of form (a~ty). They are usually + -- skolem-equalities, and they cause confusing knock-on + -- effects in other errors; see test T4093b. + , ("Skolem equalities", skolem_eq, mkReporter (mkEqErr1 ctxt)) + + , ("Unambiguous", unambiguous, reportFlatErrs ctxt) ] + (reportAmbigErrs ctxt) + (bagToList (insols `unionBags` flats)) + where + utterly_wrong, skolem_eq, unambiguous :: Ct -> PredTree -> Bool + + utterly_wrong _ (EqPred ty1 ty2) = isRigid ty1 && isRigid ty2 + utterly_wrong _ _ = False + + skolem_eq _ (EqPred ty1 ty2) = isRigidOrSkol ty1 && isRigidOrSkol ty2 + skolem_eq _ _ = False + + unambiguous ct pred + | not (any isAmbiguousTyVar (varSetElems (tyVarsOfCt ct))) + = True + | otherwise + = case pred of + EqPred ty1 ty2 -> isNothing (isTyFun_maybe ty1) && isNothing (isTyFun_maybe ty2) + _ -> False + +--------------- +isRigid, isRigidOrSkol :: Type -> Bool +isRigid ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isDecomposableTyCon tc + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + +isRigidOrSkol ty + | Just tv <- getTyVar_maybe ty = isSkolemTyVar tv + | otherwise = isRigid ty + +isTyFun_maybe :: Type -> Maybe TyCon +isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) | isSynFamilyTyCon tc -> Just tc + _ -> Nothing + +----------------- +type Reporter = [Ct] -> TcM () + +mkReporter :: (Ct -> TcM ErrMsg) -> [Ct] -> TcM () +-- Reports errors one at a time +mkReporter mk_err = mapM_ (\ct -> do { err <- setCtFlavorLoc (cc_flavor ct) $ + mk_err ct; + ; reportError err }) + +tryReporters :: [(String, Ct -> PredTree -> Bool, Reporter)] -> Reporter -> Reporter +tryReporters reporters deflt cts + = do { traceTc "tryReporters {" (ppr cts) + ; go reporters cts + ; traceTc "tryReporters }" empty } where - inaccessible_msg | Given loc GivenOrig <- (cc_flavor ct) - -- If a GivenSolved then we should not report inaccessible code - = hang (ptext (sLit "Inaccessible code in")) - 2 (ppr (ctLocOrigin loc)) - | otherwise = empty - -reportFlat :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportFlat ctxt flats origin - = do { unless (null dicts) $ reportDictErrs ctxt dicts origin - ; unless (null eqs) $ reportEqErrs ctxt eqs origin - ; unless (null ips) $ reportIPErrs ctxt ips origin - ; unless (null irreds) $ reportIrredsErrs ctxt irreds origin } + go [] cts = deflt cts + go ((str, pred, reporter) : rs) cts + | null yeses = traceTc "tryReporters: no" (text str) >> + go rs cts + | otherwise = traceTc "tryReporters: yes" (text str <+> ppr yeses) >> + reporter yeses + where + yeses = filter keep_me cts + keep_me ct = pred ct (classifyPredType (ctPred ct)) + +----------------- +mkFlatErr :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Context is already set +mkFlatErr ctxt ct -- The constraint is always wanted + = case classifyPredType (ctPred ct) of + ClassPred {} -> mkDictErr ctxt [ct] + IPPred {} -> mkIPErr ctxt [ct] + IrredPred {} -> mkIrredErr ctxt [ct] + EqPred {} -> mkEqErr1 ctxt ct + TuplePred {} -> panic "mkFlat" + +reportAmbigErrs :: ReportErrCtxt -> Reporter +reportAmbigErrs ctxt cts + | cec_insol ctxt = return () + | otherwise = reportFlatErrs ctxt cts + -- Only report ambiguity if no other errors (at all) happened + -- See Note [Avoiding spurious errors] in TcSimplify + +reportFlatErrs :: ReportErrCtxt -> Reporter +-- Called once for non-ambigs, once for ambigs +-- Report equality errors, and others only if we've done all +-- the equalities. The equality errors are more basic, and +-- can lead to knock on type-class errors +reportFlatErrs ctxt cts + = tryReporters + [ ("Equalities", is_equality, groupErrs (mkEqErr ctxt)) ] + (\cts -> do { let (dicts, ips, irreds) = go cts [] [] [] + ; groupErrs (mkIPErr ctxt) ips + ; groupErrs (mkIrredErr ctxt) irreds + ; groupErrs (mkDictErr ctxt) dicts }) + cts where - (dicts, eqs, ips, irreds) = go_many (map classifyPredType flats) - - go_many [] = ([], [], [], []) - go_many (t:ts) = (as ++ as', bs ++ bs', cs ++ cs', ds ++ ds') - where (as, bs, cs, ds) = go t - (as', bs', cs', ds') = go_many ts - - go (ClassPred cls tys) = ([(cls, tys)], [], [], []) - go (EqPred ty1 ty2) = ([], [(ty1, ty2)], [], []) - go (IPPred ip ty) = ([], [], [(ip, ty)], []) - go (IrredPred ty) = ([], [], [], [ty]) - go (TuplePred {}) = panic "reportFlat" + is_equality _ (EqPred {}) = True + is_equality _ _ = False + + go [] dicts ips irreds + = (dicts, ips, irreds) + go (ct:cts) dicts ips irreds + = case classifyPredType (ctPred ct) of + ClassPred {} -> go cts (ct:dicts) ips irreds + IPPred {} -> go cts dicts (ct:ips) irreds + IrredPred {} -> go cts dicts ips (ct:irreds) + _ -> panic "mkFlat" -- TuplePreds should have been expanded away by the constraint -- simplifier, so they shouldn't show up at this point + -- And EqPreds are dealt with by the is_equality test + -------------------------------------------- -- Support code -------------------------------------------- -groupErrs :: ([a] -> CtOrigin -> TcM ()) -- Deal with one group - -> [(WantedEvVar, a)] -- Unsolved wanteds +groupErrs :: ([Ct] -> TcM ErrMsg) -- Deal with one group + -> [Ct] -- Unsolved wanteds -> TcM () --- Group together insts with the same origin +-- Group together insts from same location -- We want to report them together in error messages groupErrs _ [] = return () -groupErrs report_err ((wanted, x) : wanteds) - = do { setCtLoc the_loc $ - report_err the_xs (ctLocOrigin the_loc) - ; groupErrs report_err others } +groupErrs mk_err (ct1 : rest) + = do { err <- setCtFlavorLoc flavor $ mk_err cts + ; reportError err + ; groupErrs mk_err others } where - the_loc = evVarX wanted - the_key = mk_key the_loc - the_xs = x:map snd friends - (friends, others) = partition (is_friend . fst) wanteds - is_friend friend = mk_key (evVarX friend) `same_key` the_key + flavor = cc_flavor ct1 + cts = ct1 : friends + (friends, others) = partition is_friend rest + is_friend friend = cc_flavor friend `same_group` flavor - mk_key :: WantedLoc -> (SrcSpan, CtOrigin) - mk_key loc = (ctLocSpan loc, ctLocOrigin loc) - - same_key (s1, o1) (s2, o2) = s1==s2 && o1 `same_orig` o2 - same_orig (OccurrenceOf n1) (OccurrenceOf n2) = n1==n2 - same_orig ScOrigin ScOrigin = True - same_orig DerivOrigin DerivOrigin = True - same_orig DefaultOrigin DefaultOrigin = True - same_orig _ _ = False + same_group :: CtFlavor -> CtFlavor -> Bool + same_group (Given l1 _) (Given l2 _) = same_loc l1 l2 + same_group (Derived l1) (Derived l2) = same_loc l1 l2 + same_group (Wanted l1) (Wanted l2) = same_loc l1 l2 + same_group _ _ = False + same_loc :: CtLoc o -> CtLoc o -> Bool + same_loc (CtLoc _ s1 _) (CtLoc _ s2 _) = s1==s2 -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc addArising orig msg = msg $$ nest 2 (pprArising orig) -pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc) +pprWithArising :: [Ct] -> (WantedLoc, SDoc) -- Print something like -- (Eq a) arising from a use of x at y -- (Show a) arising from a use of p at q -- Also return a location for the error message +-- Works for Wanted/Derived only pprWithArising [] = panic "pprWithArising" -pprWithArising [EvVarX ev loc] - = (loc, hang (pprEvVarTheta [ev]) 2 (pprArising (ctLocOrigin loc))) -pprWithArising ev_vars - = (first_loc, vcat (map ppr_one ev_vars)) +pprWithArising (ct:cts) + | null cts + = (loc, hang (pprEvVarTheta [cc_id ct]) + 2 (pprArising (ctLocOrigin (ctWantedLoc ct)))) + | otherwise + = (loc, vcat (map ppr_one (ct:cts))) where - first_loc = evVarX (head ev_vars) - ppr_one (EvVarX v loc) - = hang (parens (pprType (evVarPred v))) 2 (pprArisingAt loc) + loc = ctWantedLoc ct + ppr_one ct = hang (parens (pprType (ctPred ct))) + 2 (pprArisingAt (ctWantedLoc ct)) -addErrorReport :: ReportErrCtxt -> SDoc -> TcM () -addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) +mkErrorReport :: ReportErrCtxt -> SDoc -> TcM ErrMsg +mkErrorReport ctxt msg = mkErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) -getUserGivens :: ReportErrCtxt -> [([EvVar], GivenLoc)] +type UserGiven = ([EvVar], GivenLoc) + +getUserGivens :: ReportErrCtxt -> [UserGiven] -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ @@ -270,12 +374,14 @@ getUserGivens (CEC {cec_encl = ctxt}) %************************************************************************ \begin{code} -reportIrredsErrs :: ReportErrCtxt -> [PredType] -> CtOrigin -> TcM () -reportIrredsErrs ctxt irreds orig - = addErrorReport ctxt msg +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIrredErr ctxt cts + = mkErrorReport ctxt msg where - givens = getUserGivens ctxt - msg = couldNotDeduce givens (irreds, orig) + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + givens = getUserGivens ctxt + msg = couldNotDeduce givens (map ctPred cts, orig) \end{code} @@ -286,17 +392,21 @@ reportIrredsErrs ctxt irreds orig %************************************************************************ \begin{code} -reportIPErrs :: ReportErrCtxt -> [(IPName Name, Type)] -> CtOrigin -> TcM () -reportIPErrs ctxt ips orig - = addErrorReport ctxt msg +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkIPErr ctxt cts + = do { (ctxt', _, ambig_err) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' (msg $$ ambig_err) } where - givens = getUserGivens ctxt + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) + preds = map ctPred cts + givens = getUserGivens ctxt msg | null givens = addArising orig $ - sep [ ptext (sLit "Unbound implicit parameter") <> plural ips - , nest 2 (pprTheta (map (uncurry mkIPPred) ips)) ] + sep [ ptext (sLit "Unbound implicit parameter") <> plural cts + , nest 2 (pprTheta preds) ] | otherwise - = couldNotDeduce givens (map (uncurry mkIPPred) ips, orig) + = couldNotDeduce givens (preds, orig) \end{code} @@ -307,69 +417,88 @@ reportIPErrs ctxt ips orig %************************************************************************ \begin{code} -reportEqErrs :: ReportErrCtxt -> [(Type, Type)] -> CtOrigin -> TcM () --- The [PredType] are already tidied -reportEqErrs ctxt eqs orig - = do { orig' <- zonkTidyOrigin ctxt orig - ; mapM_ (report_one orig') eqs } +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +-- Don't have multiple equality errors from the same location +-- E.g. (Int,Bool) ~ (Bool,Int) one error will do! +mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct +mkEqErr _ [] = panic "mkEqErr" + +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg +-- Wanted constraints only! +mkEqErr1 ctxt ct + = case cc_flavor ct of + Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ + inaccessible_msg gl gk } + + flav -> do { let orig = ctLocOrigin (getWantedLoc flav) + ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig + ; mk_err ctxt1 orig' } where - report_one orig (ty1, ty2) - = do { let extra = getWantedEqExtra orig ty1 ty2 - ctxt' = ctxt { cec_extra = extra $$ cec_extra ctxt } - ; reportEqErr ctxt' ty1 ty2 } - -getWantedEqExtra :: CtOrigin -> TcType -> TcType -> SDoc -getWantedEqExtra (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) - ty1 ty2 - -- If the types in the error message are the same as the types we are unifying, - -- don't add the extra expected/actual message - | act `eqType` ty1 && exp `eqType` ty2 = empty - | exp `eqType` ty1 && act `eqType` ty2 = empty - | otherwise = mkExpectedActualMsg act exp - -getWantedEqExtra orig _ _ = pprArising orig - -reportEqErr :: ReportErrCtxt -> TcType -> TcType -> TcM () --- ty1 and ty2 are already tidied -reportEqErr ctxt ty1 ty2 - | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt tv1 ty2 - | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt tv2 ty1 - - | otherwise -- Neither side is a type variable - -- Since the unsolved constraint is canonical, - -- it must therefore be of form (F tys ~ ty) - = addErrorReport ctxt (misMatchOrCND ctxt ty1 ty2 $$ mkTyFunInfoMsg ty1 ty2) - - -reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () + -- If a GivenSolved then we should not report inaccessible code + inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in")) + 2 (ppr (ctLocOrigin loc)) + inaccessible_msg _ _ = empty + + (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct)) + + -- If the types in the error message are the same as the types + -- we are unifying, don't add the extra expected/actual message + mk_err ctxt1 (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) + | act `pickyEqType` ty1 + , exp `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty2 ty1 + | exp `pickyEqType` ty1 + , act `pickyEqType` ty2 = mkEqErr_help ctxt1 ct True ty1 ty2 + | otherwise = mkEqErr_help ctxt2 ct False ty1 ty2 + where + ctxt2 = ctxt1 { cec_extra = msg $$ cec_extra ctxt1 } + msg = mkExpectedActualMsg exp act + mk_err ctxt1 _ = mkEqErr_help ctxt1 ct False ty1 ty2 + +mkEqErr_help :: ReportErrCtxt + -> Ct + -> Bool -- True <=> Types are correct way round; + -- report "expected ty1, actual ty2" + -- False <=> Just report a mismatch without orientation + -- The ReportErrCtxt has expected/actual + -> TcType -> TcType -> TcM ErrMsg +mkEqErr_help ctxt ct oriented ty1 ty2 + | Just tv1 <- tcGetTyVar_maybe ty1 = mkTyVarEqErr ctxt ct oriented tv1 ty2 + | Just tv2 <- tcGetTyVar_maybe ty2 = mkTyVarEqErr ctxt ct oriented tv2 ty1 + | otherwise -- Neither side is a type variable + = do { ctxt' <- mkEqInfoMsg ctxt ct ty1 ty2 + ; mkErrorReport ctxt' (misMatchOrCND ctxt' ct oriented ty1 ty2) } + +mkTyVarEqErr :: ReportErrCtxt -> Ct -> Bool -> TcTyVar -> TcType -> TcM ErrMsg -- tv1 and ty2 are already tidied -reportTyVarEqErr ctxt tv1 ty2 +mkTyVarEqErr ctxt ct oriented tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would -- be oriented the other way round; see TcCanonical.reOrient || isSigTyVar tv1 && not (isTyVarTy ty2) - = addErrorReport (addExtraInfo ctxt ty1 ty2) - (misMatchOrCND ctxt ty1 ty2) + = mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) + (misMatchOrCND ctxt ct oriented ty1 ty2) -- So tv is a meta tyvar, and presumably it is -- an *untouchable* meta tyvar, else it'd have been unified | not (k2 `isSubKind` k1) -- Kind error - = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) + = mkErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2) -- Occurs check | tv1 `elemVarSet` tyVarsOfType ty2 = let occCheckMsg = hang (text "Occurs check: cannot construct the infinite type:") 2 (sep [ppr ty1, char '=', ppr ty2]) - in addErrorReport ctxt occCheckMsg + in mkErrorReport ctxt occCheckMsg -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context - , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic) + , let esc_skols = filter (`elemVarSet` (tyVarsOfType ty2)) (ic_skols implic) implic_loc = ic_loc implic , not (null esc_skols) = setCtLoc implic_loc $ -- Override the error message location from the -- place the equality arose to the implication site - do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1) - ; let msg = misMatchMsg ty1 ty2 + do { (ctxt', env_sigs) <- findGlobals ctxt (unitVarSet tv1) + ; let msg = misMatchMsg oriented ty1 ty2 esc_doc = sep [ ptext (sLit "because type variable") <> plural esc_skols <+> pprQuotedList esc_skols , ptext (sLit "would escape") <+> @@ -381,23 +510,23 @@ reportTyVarEqErr ctxt tv1 ty2 else ptext (sLit "These (rigid, skolem) type variables are")) <+> ptext (sLit "bound by") , nest 2 $ ppr (ctLocOrigin implic_loc) ] ] - ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } + ; mkErrorReport ctxt' (msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) } -- Nastiest case: attempt to unify an untouchable variable | (implic:_) <- cec_encl ctxt -- Get the innermost context , let implic_loc = ic_loc implic given = ic_given implic = setCtLoc (ic_loc implic) $ - do { let msg = misMatchMsg ty1 ty2 + do { let msg = misMatchMsg oriented ty1 ty2 extra = quotes (ppr tv1) <+> sep [ ptext (sLit "is untouchable") , ptext (sLit "inside the constraints") <+> pprEvVarTheta given , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] - ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } + ; mkErrorReport (addExtraTyVarInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } | otherwise - = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ - return () + = pprTrace "mkTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + panic "mkTyVarEqErr" -- I don't think this should happen, and if it does I want to know -- Trac #5130 happened because an actual type error was not -- reported at all! So not reporting is pretty dangerous. @@ -416,30 +545,43 @@ reportTyVarEqErr ctxt tv1 ty2 k2 = typeKind ty2 ty1 = mkTyVarTy tv1 -mkTyFunInfoMsg :: TcType -> TcType -> SDoc --- See Note [Non-injective type functions] -mkTyFunInfoMsg ty1 ty2 - | Just (tc1,_) <- tcSplitTyConApp_maybe ty1 - , Just (tc2,_) <- tcSplitTyConApp_maybe ty2 - , tc1 == tc2, isSynFamilyTyCon tc1 - = ptext (sLit "NB:") <+> quotes (ppr tc1) - <+> ptext (sLit "is a type function") <> (pp_inj tc1) - | otherwise = empty - where - pp_inj tc | isInjectiveTyCon tc = empty - | otherwise = ptext (sLit (", and may not be injective")) - -misMatchOrCND :: ReportErrCtxt -> TcType -> TcType -> SDoc -misMatchOrCND ctxt ty1 ty2 - | cec_insol ctxt = misMatchMsg ty1 ty2 -- If the equality is unconditionally - -- insoluble, don't report the context - | null givens = misMatchMsg ty1 ty2 - | otherwise = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) +mkEqInfoMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> TcM ReportErrCtxt +-- Report (a) ambiguity if either side is a type function application +-- e.g. F a0 ~ Int +-- (b) warning about injectivity if both sides are the same +-- type function application F a ~ F b +-- See Note [Non-injective type functions] +mkEqInfoMsg ctxt ct ty1 ty2 + = do { (ctxt', _, ambig_msg) <- if isJust mb_fun1 || isJust mb_fun2 + then mkAmbigMsg ctxt [ct] + else return (ctxt, False, empty) + ; return (ctxt' { cec_extra = tyfun_msg $$ ambig_msg $$ cec_extra ctxt' }) } + where + mb_fun1 = isTyFun_maybe ty1 + mb_fun2 = isTyFun_maybe ty2 + tyfun_msg | Just tc1 <- mb_fun1 + , Just tc2 <- mb_fun2 + , tc1 == tc2 + = ptext (sLit "NB:") <+> quotes (ppr tc1) + <+> ptext (sLit "is a type function, and may not be injective") + | otherwise = empty + +misMatchOrCND :: ReportErrCtxt -> Ct -> Bool -> TcType -> TcType -> SDoc +-- If oriented then ty1 is expected, ty2 is actual +misMatchOrCND ctxt ct oriented ty1 ty2 + | null givens || + (isRigid ty1 && isRigid ty2) || + isGivenOrSolved (cc_flavor ct) + -- If the equality is unconditionally insoluble + -- or there is no context, don't report the context + = misMatchMsg oriented ty1 ty2 + | otherwise + = couldNotDeduce givens ([mkEqPred (ty1, ty2)], orig) where givens = getUserGivens ctxt orig = TypeEqOrigin (UnifyOrigin ty1 ty2) -couldNotDeduce :: [([EvVar], GivenLoc)] -> (ThetaType, CtOrigin) -> SDoc +couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc couldNotDeduce givens (wanteds, orig) = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) 2 (pprArising orig) @@ -456,35 +598,18 @@ pp_givens givens 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) -addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt +addExtraTyVarInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt -- Add on extra info about the types themselves -- NB: The types themselves are already tidied -addExtraInfo ctxt ty1 ty2 +addExtraTyVarInfo ctxt ty1 ty2 = ctxt { cec_extra = nest 2 (extra1 $$ extra2) $$ cec_extra ctxt } where - extra1 = typeExtraInfoMsg (cec_encl ctxt) ty1 - extra2 = typeExtraInfoMsg (cec_encl ctxt) ty2 - -misMatchMsg :: TcType -> TcType -> SDoc -- Types are already tidy -misMatchMsg ty1 ty2 - = sep [ ptext cm_ty_or_knd <+> quotes (ppr ty1) - , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)] - where cm_ty_or_knd - | isKind ty1 = sLit "Couldn't match kind" - | otherwise = sLit "Couldn't match type" - -kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy -kindErrorMsg ty1 ty2 - = vcat [ ptext (sLit "Kind incompatibility when matching types:") - , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 - , ppr ty2 <+> dcolon <+> ppr k2 ]) ] - where - k1 = typeKind ty1 - k2 = typeKind ty2 + extra1 = tyVarExtraInfoMsg (cec_encl ctxt) ty1 + extra2 = tyVarExtraInfoMsg (cec_encl ctxt) ty2 -typeExtraInfoMsg :: [Implication] -> Type -> SDoc +tyVarExtraInfoMsg :: [Implication] -> Type -> SDoc -- Shows a bit of extra info about skolem constants -typeExtraInfoMsg implics ty +tyVarExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty , isTcTyVar tv, isSkolemTyVar tv , let pp_tv = quotes (ppr tv) @@ -502,15 +627,37 @@ typeExtraInfoMsg implics ty ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), sep [ppr info, ptext (sLit "at") <+> ppr loc]] +kindErrorMsg :: TcType -> TcType -> SDoc -- Types are already tidy +kindErrorMsg ty1 ty2 + = vcat [ ptext (sLit "Kind incompatibility when matching types:") + , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1 + , ppr ty2 <+> dcolon <+> ppr k2 ]) ] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env = do { (env1, act_ty') <- zonkTidyTcType tidy_env act_ty ; (env2, exp_ty') <- zonkTidyTcType env1 exp_ty - ; return (env2, mkExpectedActualMsg act_ty' exp_ty') } + ; return (env2, mkExpectedActualMsg exp_ty' act_ty') } + +misMatchMsg :: Bool -> TcType -> TcType -> SDoc -- Types are already tidy +-- If oriented then ty1 is expected, ty2 is actual +misMatchMsg oriented ty1 ty2 + | oriented + = sep [ ptext (sLit "Couldn't match expected") <+> what <+> quotes (ppr ty1) + , nest 12 $ ptext (sLit "with actual") <+> what <+> quotes (ppr ty2) ] + | otherwise + = sep [ ptext (sLit "Couldn't match") <+> what <+> quotes (ppr ty1) + , nest 14 $ ptext (sLit "with") <+> quotes (ppr ty2) ] + where + what | isKind ty1 = ptext (sLit "kind") + | otherwise = ptext (sLit "type") mkExpectedActualMsg :: Type -> Type -> SDoc -mkExpectedActualMsg act_ty exp_ty +mkExpectedActualMsg exp_ty act_ty = vcat [ text "Expected type" <> colon <+> ppr exp_ty , text " Actual type" <> colon <+> ppr act_ty ] \end{code} @@ -533,27 +680,33 @@ Warn of loopy local equalities that were dropped. %************************************************************************ \begin{code} -reportDictErrs :: ReportErrCtxt -> [(Class, [Type])] -> CtOrigin -> TcM () -reportDictErrs ctxt wanteds orig +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg +mkDictErr ctxt cts = do { inst_envs <- tcGetInstEnvs - ; non_overlaps <- filterM (reportOverlap ctxt inst_envs orig) wanteds - ; unless (null non_overlaps) $ - addErrorReport ctxt (mk_no_inst_err non_overlaps) } + ; stuff <- mapM (mkOverlap ctxt inst_envs orig) cts + ; let (non_overlaps, overlap_errs) = partitionEithers stuff + ; if null non_overlaps + then mkErrorReport ctxt (vcat overlap_errs) + else do + { (ctxt', is_ambig, ambig_msg) <- mkAmbigMsg ctxt cts + ; mkErrorReport ctxt' + (vcat [ mkNoInstErr givens non_overlaps orig + , ambig_msg + , mk_no_inst_fixes is_ambig non_overlaps]) } } where - mk_no_inst_err :: [(Class, [Type])] -> SDoc - mk_no_inst_err wanteds - | null givens -- Top level - = vcat [ addArising orig $ - ptext (sLit "No instance") <> plural min_wanteds - <+> ptext (sLit "for") <+> pprTheta min_wanteds - , show_fixes (fixes2 ++ fixes3) ] + (ct1:_) = cts + orig = ctLocOrigin (ctWantedLoc ct1) - | otherwise - = vcat [ couldNotDeduce givens (min_wanteds, orig) - , show_fixes (fixes1 ++ fixes2 ++ fixes3) ] + givens = getUserGivens ctxt + + mk_no_inst_fixes is_ambig cts + | null givens = show_fixes (fixes2 ++ fixes3) + | otherwise = show_fixes (fixes1 ++ fixes2 ++ fixes3) where - givens = getUserGivens ctxt - min_wanteds = mkMinimalBySCs (map (uncurry mkClassPred) wanteds) + min_wanteds = map ctPred cts + instance_dicts = filterOut isTyVarClassPred min_wanteds + -- Insts for which it is worth suggesting an adding an + -- instance declaration. Exclude tyvar dicts. fixes2 = case instance_dicts of [] -> [] @@ -565,19 +718,11 @@ reportDictErrs ctxt wanteds orig DerivOrigin -> [drv_fix] _ -> [] - instance_dicts = filterOut isTyVarClassPred min_wanteds - -- Insts for which it is worth suggesting an adding an - -- instance declaration. Exclude tyvar dicts. - drv_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration,"), nest 2 $ ptext (sLit "so you can specify the instance context yourself")] - show_fixes :: [SDoc] -> SDoc - show_fixes [] = empty - show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), - nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] - - fixes1 | (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) + fixes1 | not is_ambig + , (orig:origs) <- mapCatMaybes get_good_orig (cec_encl ctxt) = [sep [ ptext (sLit "add") <+> pprTheta min_wanteds <+> ptext (sLit "to the context of") , nest 2 $ ppr_skol orig $$ @@ -594,19 +739,38 @@ reportDictErrs ctxt wanteds orig SigSkol (InfSigCtxt {}) _ -> Nothing origin -> Just origin -reportOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin - -> (Class, [Type]) -> TcM Bool + + show_fixes :: [SDoc] -> SDoc + show_fixes [] = empty + show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:") + , nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))] + +mkNoInstErr :: [UserGiven] -> [Ct] -> CtOrigin -> SDoc +mkNoInstErr givens cts orig + | null givens -- Top level + = addArising orig $ + ptext (sLit "No instance") <> plural cts + <+> ptext (sLit "for") <+> pprTheta theta + + | otherwise + = couldNotDeduce givens (theta, orig) + where + theta = map ctPred cts + +mkOverlap :: ReportErrCtxt -> (InstEnv,InstEnv) -> CtOrigin + -> Ct -> TcM (Either Ct SDoc) -- Report an overlap error if this class constraint results --- from an overlap (returning Nothing), otherwise return (Just pred) -reportOverlap ctxt inst_envs orig (clas, tys) +-- from an overlap (returning Left clas), otherwise return (Right pred) +mkOverlap ctxt inst_envs orig ct = do { tys_flat <- mapM quickFlattenTy tys -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _, _) -> return True -- No match - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return False } } + ([], _, _) -> return (Left ct) -- No match + res -> return (Right (mk_overlap_msg res)) } where + (clas, tys) = getClassPredTys (ctPred ct) + -- Normal overlap error mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) @@ -730,66 +894,60 @@ that match such things. And flattening under a for-all is problematic anyway; consider C (forall a. F a) \begin{code} -reportAmbigErrs :: ReportErrCtxt -> [WantedEvVar] -> TcM () -reportAmbigErrs ctxt ambigs --- Divide into groups that share a common set of ambiguous tyvars - = mapM_ (reportAmbigGroup ctxt) (equivClasses cmp ambigs_w_tvs) - where - ambigs_w_tvs = [ (d, filter isAmbiguousTyVar (varSetElems (tyVarsOfEvVarX d))) - | d <- ambigs ] - cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 - - -reportAmbigGroup :: ReportErrCtxt -> [(WantedEvVar, [TcTyVar])] -> TcM () --- The pairs all have the same [TcTyVar] -reportAmbigGroup ctxt pairs - = setCtLoc loc $ - do { dflags <- getDOpts - ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet tvs) - ; addErrTcM (tidy_env, main_msg $$ mk_msg dflags docs) } +mkAmbigMsg :: ReportErrCtxt -> [Ct] + -> TcM (ReportErrCtxt, Bool, SDoc) +mkAmbigMsg ctxt cts + | isEmptyVarSet ambig_tv_set + = return (ctxt, False, empty) + | otherwise + = do { dflags <- getDOpts + ; (ctxt', gbl_docs) <- findGlobals ctxt ambig_tv_set + ; return (ctxt', True, mk_msg dflags gbl_docs) } where - (wev, tvs) : _ = pairs - (loc, pp_wanteds) = pprWithArising (map fst pairs) - main_msg = sep [ text "Ambiguous type variable" <> plural tvs - <+> pprQuotedList tvs - <+> text "in the constraint" <> plural pairs <> colon - , nest 2 pp_wanteds ] - + ambig_tv_set = foldr (unionVarSet . filterVarSet isAmbiguousTyVar . tyVarsOfCt) + emptyVarSet cts + ambig_tvs = varSetElems ambig_tv_set + + is_or_are | isSingleton ambig_tvs = text "is" + | otherwise = text "are" + mk_msg dflags docs - | any isRuntimeUnkSkol tvs -- See Note [Runtime skolems] - = vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+> - (pprWithCommas ppr tvs), - ptext (sLit "Use :print or :force to determine these types")] - - | DerivOrigin <- ctLocOrigin (evVarX wev) - = ptext (sLit "Probable fix: use a 'standalone deriving' declaration instead") - - | null docs - = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)") + | any isRuntimeUnkSkol ambig_tvs -- See Note [Runtime skolems] + = vcat [ ptext (sLit "Cannot resolve unknown runtime type") <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + , ptext (sLit "Use :print or :force to determine these types")] + | otherwise + = vcat [ text "The type variable" <> plural ambig_tvs + <+> pprQuotedList ambig_tvs + <+> is_or_are <+> text "ambiguous" + , mk_extra_msg dflags docs ] + + mk_extra_msg dflags docs + | null docs + = ptext (sLit "Possible fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") -- where monomorphism doesn't play any role - | otherwise - = vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"), - nest 2 (vcat docs), - mono_fix dflags] - - mono_fix :: DynFlags -> SDoc - mono_fix dflags - = ptext (sLit "Probable fix:") <+> vcat - [ptext (sLit "give these definition(s) an explicit type signature"), - if xopt Opt_MonomorphismRestriction dflags - then ptext (sLit "or use -XNoMonomorphismRestriction") - else empty] -- Only suggest adding "-XNoMonomorphismRestriction" - -- if it is not already set! + | otherwise + = vcat [ ptext (sLit "Possible cause: the monomorphism restriction applied to the following:") + , nest 2 (vcat docs) + , ptext (sLit "Probable fix:") <+> vcat + [ ptext (sLit "give these definition(s) an explicit type signature") + , if xopt Opt_MonomorphismRestriction dflags + then ptext (sLit "or use -XNoMonomorphismRestriction") + else empty ] -- Only suggest adding "-XNoMonomorphismRestriction" + -- if it is not already set! + ] getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo +-- Get the skolem info for a type variable +-- from the implication constraint that binds it getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) UnkSkol getSkolemInfo (implic:implics) tv - | tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic) - | otherwise = getSkolemInfo implics tv + | tv `elem` ic_skols implic = ctLocOrigin (ic_loc implic) + | otherwise = getSkolemInfo implics tv ----------------------- -- findGlobals looks at the value environment and finds values whose @@ -805,7 +963,7 @@ mkEnvSigMsg what env_sigs findGlobals :: ReportErrCtxt -> TcTyVarSet - -> TcM (TidyEnv, [SDoc]) + -> TcM (ReportErrCtxt, [SDoc]) findGlobals ctxt tvs = do { lcl_ty_env <- case cec_encl ctxt of @@ -813,12 +971,12 @@ findGlobals ctxt tvs (i:_) -> return (ic_env i) ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) } where - go tidy_env acc [] = return (tidy_env, acc) - go tidy_env acc (thing : things) = do - (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing - case maybe_doc of - Just d -> go tidy_env1 (d:acc) things - Nothing -> go tidy_env1 acc things + go tidy_env acc [] = return (ctxt { cec_tidy = tidy_env }, acc) + go tidy_env acc (thing : things) + = do { (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing + ; case maybe_doc of + Just d -> go tidy_env1 (d:acc) things + Nothing -> go tidy_env1 acc things } ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty @@ -862,18 +1020,11 @@ warnDefaulting wanteds default_ty tidy_env = tidyFreeTyVars env0 $ tyVarsOfCts wanted_bag tidy_wanteds = mapBag (tidyCt tidy_env) wanted_bag - (loc, ppr_wanteds) = pprWithArising (map mk_wev (bagToList tidy_wanteds)) + (loc, ppr_wanteds) = pprWithArising (bagToList tidy_wanteds) warn_msg = hang (ptext (sLit "Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) 2 ppr_wanteds ; setCtLoc loc $ warnTc warn_default warn_msg } - where mk_wev :: Ct -> WantedEvVar - mk_wev ct - | ev <- cc_id ct - , Wanted wloc <- cc_flavor ct - = EvVarX ev wloc -- must return a WantedEvVar - mk_wev _ct = panic "warnDefaulting: encountered non-wanted for defaulting" - \end{code} Note [Runtime skolems] @@ -890,13 +1041,12 @@ are created by in RtClosureInspect.zonkRTTIType. %************************************************************************ \begin{code} -solverDepthErrorTcS :: Int -> [Ct] -> TcS a +solverDepthErrorTcS :: Int -> [Ct] -> TcM a solverDepthErrorTcS depth stack | null stack -- Shouldn't happen unless you say -fcontext-stack=0 - = wrapErrTcS $ failWith msg + = failWith msg | otherwise - = wrapErrTcS $ - setCtFlavorLoc (cc_flavor top_item) $ + = setCtFlavorLoc (cc_flavor top_item) $ do { ev_vars <- mapM (zonkEvVar . cc_id) stack ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) @@ -907,10 +1057,9 @@ solverDepthErrorTcS depth stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] -flattenForAllErrorTcS :: CtFlavor -> TcType -> TcS a +flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a flattenForAllErrorTcS fl ty - = wrapErrTcS $ - setCtFlavorLoc fl $ + = setCtFlavorLoc fl $ do { env0 <- tcInitTidyEnv ; let (env1, ty') = tidyOpenType env0 ty msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:") @@ -942,12 +1091,11 @@ zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType) zonkTidyTcType env ty = do { ty' <- zonkTcType ty ; return (tidyOpenType env ty') } -zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM CtOrigin +zonkTidyOrigin :: ReportErrCtxt -> CtOrigin -> TcM (ReportErrCtxt, CtOrigin) zonkTidyOrigin ctxt (TypeEqOrigin (UnifyOrigin { uo_actual = act, uo_expected = exp })) = do { (env1, act') <- zonkTidyTcType (cec_tidy ctxt) act - ; (_env2, exp') <- zonkTidyTcType env1 exp - ; return (TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } - -- Drop the returned env on the floor; we may conceivably thereby get - -- inconsistent naming between uses of this function -zonkTidyOrigin _ orig = return orig + ; (env2, exp') <- zonkTidyTcType env1 exp + ; return ( ctxt { cec_tidy = env2 } + , TypeEqOrigin (UnifyOrigin { uo_actual = act', uo_expected = exp' })) } +zonkTidyOrigin ctxt orig = return (ctxt, orig) \end{code} diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs index a6a7ce3dc0..93c5bf56ea 100644 --- a/compiler/typecheck/TcEvidence.lhs +++ b/compiler/typecheck/TcEvidence.lhs @@ -462,6 +462,10 @@ data EvTerm | EvTupleMk [EvId] -- tuple built from this stuff
+ | EvDelayedError Type FastString -- Used with Opt_DeferTypeErrors
+ -- See Note [Deferring coercion errors to runtime]
+ -- in TcSimplify
+
| EvSuperClass DictId Int -- n'th superclass. Used for both equalities and
-- dictionaries, even though the former have no
-- selector Id. We count up from _0_
@@ -559,12 +563,13 @@ isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" evVarsOfTerm :: EvTerm -> [EvVar]
evVarsOfTerm (EvId v) = [v]
-evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvDFunApp _ _ evs) = evs
-evVarsOfTerm (EvTupleSel v _) = [v]
-evVarsOfTerm (EvSuperClass v _) = [v]
-evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
-evVarsOfTerm (EvTupleMk evs) = evs
+evVarsOfTerm (EvCoercion co) = varSetElems (coVarsOfTcCo co)
+evVarsOfTerm (EvDFunApp _ _ evs) = evs
+evVarsOfTerm (EvTupleSel v _) = [v]
+evVarsOfTerm (EvSuperClass v _) = [v]
+evVarsOfTerm (EvCast v co) = v : varSetElems (coVarsOfTcCo co)
+evVarsOfTerm (EvTupleMk evs) = evs
+evVarsOfTerm (EvDelayedError _ _) = []
evVarsOfTerm (EvKindCast v co) = v : varSetElems (coVarsOfTcCo co)
evVarsOfTerm (EvInteger _) = []
\end{code}
@@ -618,14 +623,16 @@ instance Outputable EvBind where -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing
instance Outputable EvTerm where
- ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
- ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co
- ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
- ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
- ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
- ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
- ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
- ppr (EvInteger n) = integer n
+ ppr (EvId v) = ppr v
+ ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co
+ ppr (EvKindCast v co) = ppr v <+> (ptext (sLit "`kind-cast`")) <+> pprParendTcCo co
+ ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
+ ppr (EvTupleSel v n) = ptext (sLit "tupsel") <> parens (ppr (v,n))
+ ppr (EvTupleMk vs) = ptext (sLit "tupmk") <+> ppr vs
+ ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
+ ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
+ ppr (EvInteger n) = integer n
+ ppr (EvDelayedError ty msg) = ptext (sLit "error")
+ <+> sep [ char '@' <> ppr ty, ppr msg ]
\end{code}
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 67f212fd98..a3b33bca60 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -1395,7 +1395,7 @@ funAppCtxt fun arg arg_no 2 (quotes (ppr arg)) funResCtxt :: LHsExpr Name -> TcType -> TcType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) -- When we have a mis-match in the return type of a function -- try to give a helpful message about too many/few arguments funResCtxt fun fun_res_ty res_ty env0 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index f1c1e9c438..bf3bcbebe8 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -468,7 +468,7 @@ checkCConv CmmCallConv = panic "checkCConv CmmCallConv" Warnings \begin{code} -check :: Bool -> Message -> TcM () +check :: Bool -> MsgDoc -> TcM () check True _ = return () check _ the_err = addErrTc the_err @@ -483,7 +483,7 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> Message +badCName :: CLabelString -> MsgDoc badCName target = sep [quotes (ppr target) <+> ptext (sLit "is not a valid C identifier")] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 0ac550d10c..934b1be361 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -1118,6 +1118,9 @@ zonkEvTerm env (EvDFunApp df tys tms) = do { tys' <- zonkTcTypeToTypes env tys ; let tms' = map (zonkEvVarOcc env) tms ; return (EvDFunApp (zonkIdOcc env df) tys' tms') } +zonkEvTerm env (EvDelayedError ty msg) + = do { ty' <- zonkTcTypeToType env ty + ; return (EvDelayedError ty' msg) } zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds) zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index b491e7d755..3cc95a09f2 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -7,7 +7,6 @@ -- for details module TcInteract ( - solveInteractWanted, -- Solves [WantedEvVar] solveInteractGiven, -- Solves [EvVar],GivenLoc solveInteractCts, -- Solves [Cts] ) where @@ -105,20 +104,30 @@ solveInteractCts cts -> Ct -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) solve_or_cache (acc_cts,acc_cache) ct - | isIPPred pty - = return (ct:acc_cts,acc_cache) -- Do not use the cache, - -- nor update it for IPPreds due to subtle shadowing - | Just (ev',fl') <- lookupTM pty acc_cache + | dont_cache (classifyPredType pred_ty) + = return (ct:acc_cts,acc_cache) + + | Just (ev',fl') <- lookupTM pred_ty acc_cache , fl' `canSolve` fl , isWanted fl = do { _ <- setEvBind ev (EvId ev') fl ; return (acc_cts,acc_cache) } + | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pty (\_ -> Just (ev,fl)) acc_cache) + = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) where fl = cc_flavor ct ev = cc_id ct - pty = ctPred ct - + pred_ty = ctPred ct + + dont_cache :: PredTree -> Bool + -- Do not use the cache, not update it, if this is true + dont_cache (IPPred {}) = True -- IPPreds have subtle shadowing + dont_cache (EqPred ty1 ty2) -- Report Int ~ Bool errors separately + | Just tc1 <- tyConAppTyCon_maybe ty1 + , Just tc2 <- tyConAppTyCon_maybe ty2 + , tc1 /= tc2 + = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 + dont_cache _ = False solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () solveInteractGiven gloc evs @@ -127,14 +136,6 @@ solveInteractGiven gloc evs , cc_flavor = Given gloc GivenOrig , cc_depth = 0 } -solveInteractWanted :: [WantedEvVar] -> TcS () --- Solve these wanteds along with current inerts and wanteds! -solveInteractWanted wevs - = solveInteractCts (map mk_noncan wevs) - where mk_noncan (EvVarX v w) - = CNonCanonical { cc_id = v, cc_flavor = Wanted w, cc_depth = 0 } - - -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- solveInteract :: TcS () @@ -150,7 +151,7 @@ solveInteract NoWorkRemaining -- Done, successfuly (modulo frozen) -> return () MaxDepthExceeded ct -- Failure, depth exceeded - -> solverDepthErrorTcS (cc_depth ct) [ct] + -> wrapErrTcS $ solverDepthErrorTcS (cc_depth ct) [ct] NextWorkItem ct -- More work, loop around! -> runSolverPipeline thePipeline ct >> solve_loop } ; solve_loop } @@ -1444,7 +1445,9 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc -- Wanted dictionary doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) - , cc_class = cls, cc_tyargs = xis }) + , cc_id = dict_id + , cc_class = cls, cc_tyargs = xis + , cc_depth = depth }) -- See Note [MATCHING-SYNONYMS] = do { traceTcS "doTopReact" (ppr workItem) ; instEnvs <- getInstEnvs @@ -1458,7 +1461,7 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) do { lkup_inst_res <- matchClassInst inerts cls xis loc ; case lkup_inst_res of GenInst wtvs ev_term - -> doSolveFromInstance wtvs ev_term workItem + -> doSolveFromInstance wtvs ev_term NoInstance -> return NoTopInt } @@ -1468,31 +1471,26 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) ; return SomeTopInt { tir_rule = "Dict/Top (fundeps)" , tir_new_item = ContinueWith workItem } } } - where doSolveFromInstance :: [WantedEvVar] - -> EvTerm - -> Ct - -> TcS TopInteractResult + where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult -- Precondition: evidence term matches the predicate of cc_id of workItem - doSolveFromInstance wtvs ev_term workItem - | null wtvs - = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem)) - ; _ <- setEvBind (cc_id workItem) ev_term fl + doSolveFromInstance evs ev_term + | null evs + = do { traceTcS "doTopReact/found nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" , tir_new_item = Stop } } -- Don't put him in the inerts | otherwise - = do { traceTcS "doTopReact/found non-nullary instance for" $ - ppr (cc_id workItem) - ; _ <- setEvBind (cc_id workItem) ev_term fl + = do { traceTcS "doTopReact/found non-nullary instance for" (ppr dict_id) + ; _ <- setEvBind dict_id ev_term fl -- Solved and new wanted work produced, you may cache the -- (tentatively solved) dictionary as Solved given. -- ; let _solved = workItem { cc_flavor = solved_fl } -- solved_fl = mkSolvedFlavor fl UnkSkol - ; let ct_from_wev (EvVarX v fl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted fl - , cc_depth = cc_depth workItem + 1 } - wtvs_cts = map ct_from_wev wtvs - ; updWorkListTcS (appendWorkListCt wtvs_cts) + ; let mk_new_wanted ev + = CNonCanonical { cc_id = ev, cc_flavor = fl + , cc_depth = depth + 1 } + ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } @@ -1764,7 +1762,7 @@ NB: The desugarer needs be more clever to deal with equalities \begin{code} data LookupInstResult = NoInstance - | GenInst [WantedEvVar] EvTerm + | GenInst [EvVar] EvTerm matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult @@ -1805,10 +1803,9 @@ matchClassInst inerts clas tys loc else do { evc_vars <- instDFunConstraints theta (Wanted loc) ; let ev_vars = map evc_the_evvar evc_vars - new_evc_vars = filter isNewEvVar evc_vars - wevs = map (\v -> EvVarX (evc_the_evvar v) loc) new_evc_vars - -- wevs are only the real new variables that can be emitted - ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } + new_ev_vars = [evc_the_evvar evc | evc <- evc_vars, isNewEvVar evc] + -- new_ev_vars are only the real new variables that can be emitted + ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } } } where diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 395b47770f..e131c3d1a2 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -66,9 +66,8 @@ module TcMType ( zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcKind, defaultKindVarToStar, zonkCt, zonkCts, - zonkImplication, zonkEvVar, zonkWantedEvVar, + zonkImplication, zonkEvVar, zonkWC, - zonkWC, zonkWantedEvVars, zonkTcTypeAndSubst, tcGetGlobalTyVars, @@ -695,12 +694,6 @@ zonkCt ct zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt -zonkWantedEvVars :: Bag WantedEvVar -> TcM (Bag WantedEvVar) -zonkWantedEvVars = mapBagM zonkWantedEvVar - -zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar -zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) } - zonkFlavor :: CtFlavor -> TcM CtFlavor zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } zonkFlavor fl = return fl @@ -1629,7 +1622,7 @@ The underlying idea is that \begin{code} -checkInstTermination :: [TcType] -> ThetaType -> [Message] +checkInstTermination :: [TcType] -> ThetaType -> [MsgDoc] checkInstTermination tys theta = mapCatMaybes check theta where @@ -1686,7 +1679,7 @@ checkValidFamInst typats rhs -- checkFamInstRhs :: [Type] -- lhs -> [(TyCon, [Type])] -- type family instances - -> [Message] + -> [MsgDoc] checkFamInstRhs lhsTys famInsts = mapCatMaybes check famInsts where diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 1474686c15..333c2d0984 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -31,6 +31,7 @@ import TcMType import TcType import TcBinds import TcUnify +import TcErrors ( misMatchMsg ) import Name import TysWiredIn import Id @@ -876,5 +877,22 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty + +failWithMisMatch :: [EqOrigin] -> TcM a +-- Generate the message when two types fail to match, +-- going to some trouble to make it helpful. +-- We take the failing types from the top of the origin stack +-- rather than reporting the particular ones we are looking +-- at right now +failWithMisMatch (item:origin) + = wrapEqCtxt origin $ + do { ty_act <- zonkTcType (uo_actual item) + ; ty_exp <- zonkTcType (uo_expected item) + ; env0 <- tcInitTidyEnv + ; let (env1, pp_exp) = tidyOpenType env0 ty_exp + (env2, pp_act) = tidyOpenType env1 ty_act + ; failWithTcM (env2, misMatchMsg True pp_exp pp_act) } +failWithMisMatch [] + = panic "failWithMisMatch" \end{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index bb1013b33d..4e46de90d9 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -191,7 +191,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Process the export list traceRn (text "rn4a: before exports"); tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; - traceRn (text "rn4b: after exportss") ; + traceRn (text "rn4b: after exports") ; -- Check that main is exported (must be after rnExports) checkMainExported tcg_env ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 08125d75d0..2c6461fef9 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -450,7 +450,7 @@ traceOptTcRn :: DynFlag -> SDoc -> TcRn () traceOptTcRn flag doc = ifDOptM flag $ do { loc <- getSrcSpanM ; let real_doc - | opt_PprStyle_Debug = mkLocMessage loc doc + | opt_PprStyle_Debug = mkLocMessage SevInfo loc doc | otherwise = doc -- The full location is -- usually way too much ; dumpTcRn real_doc } @@ -563,13 +563,13 @@ getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: Message -> TcRn () -- Ignores the context stack +addErr :: MsgDoc -> TcRn () -- Ignores the context stack addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: Message -> TcRn a +failWith :: MsgDoc -> TcRn a failWith msg = addErr msg >> failM -addErrAt :: SrcSpan -> Message -> TcRn () +addErrAt :: SrcSpan -> MsgDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter @@ -578,22 +578,16 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo tidy_env ctxt ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,Message)] -> TcRn () +addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty - -addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty - -checkErr :: Bool -> Message -> TcRn () +checkErr :: Bool -> MsgDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -warnIf :: Bool -> Message -> TcRn () +warnIf :: Bool -> MsgDoc -> TcRn () warnIf True msg = addWarn msg warnIf False _ = return () @@ -628,29 +622,31 @@ discardWarnings thing_inside %************************************************************************ \begin{code} -addReport :: Message -> Message -> TcRn () -addReport msg extra_info = do { traceTc "addr" msg; loc <- getSrcSpanM; addReportAt loc msg extra_info } - -addReportAt :: SrcSpan -> Message -> Message -> TcRn () -addReportAt loc msg extra_info - = do { errs_var <- getErrsVar ; +mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg +mkLongErrAt loc msg extra + = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ; rdr_env <- getGlobalRdrEnv ; dflags <- getDOpts ; - let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) - msg extra_info } ; - (warns, errs) <- readTcRef errs_var ; - writeTcRef errs_var (warns `snocBag` warn, errs) } + return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; +addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError + +reportErrors :: [ErrMsg] -> TcM () +reportErrors = mapM_ reportError + +reportError :: ErrMsg -> TcRn () +reportError err + = do { errs_var <- getErrsVar ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns, errs `snocBag` err) } +reportWarning :: ErrMsg -> TcRn () +reportWarning warn + = do { errs_var <- getErrsVar ; + (warns, errs) <- readTcRef errs_var ; + writeTcRef errs_var (warns `snocBag` warn, errs) } + dumpDerivingInfo :: SDoc -> TcM () dumpDerivingInfo doc = do { dflags <- getDOpts @@ -773,9 +769,9 @@ checkNoErrs main } ifErrsM :: TcRn r -> TcRn r -> TcRn r --- ifErrsM bale_out main +-- ifErrsM bale_out normal -- does 'bale_out' if there are errors in errors collection --- otherwise does 'main' +-- otherwise does 'normal' ifErrsM bale_out normal = do { errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; @@ -804,13 +800,13 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -addErrCtxt :: Message -> TcM a -> TcM a +addErrCtxt :: MsgDoc -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts) -addLandmarkErrCtxt :: Message -> TcM a -> TcM a +addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a addLandmarkErrCtxt msg = updCtxt (\ctxts -> (True, \env -> return (env,msg)) : ctxts) -- Helper function for the above @@ -842,32 +838,40 @@ setCtLoc (CtLoc _ src_loc ctxt) thing_inside tidy up the message; we then use it to tidy the context messages \begin{code} -addErrTc :: Message -> TcM () +addErrTc :: MsgDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrsTc :: [Message] -> TcM () +addErrsTc :: [MsgDoc] -> TcM () addErrsTc err_msgs = mapM_ addErrTc err_msgs -addErrTcM :: (TidyEnv, Message) -> TcM () +addErrTcM :: (TidyEnv, MsgDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } + +-- Return the error message, instead of reporting it straight away +mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg +mkErrTcM (tidy_env, err_msg) + = do { ctxt <- getErrCtxt ; + loc <- getSrcSpanM ; + err_info <- mkErrInfo tidy_env ctxt ; + mkLongErrAt loc err_msg err_info } \end{code} The failWith functions add an error message and cause failure \begin{code} -failWithTc :: Message -> TcM a -- Add an error message and fail +failWithTc :: MsgDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true +checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err \end{code} @@ -875,20 +879,39 @@ checkTc False err = failWithTc err Warnings have no 'M' variant, nor failure \begin{code} -addWarnTc :: Message -> TcM () +warnTc :: Bool -> MsgDoc -> TcM () +warnTc warn_if_true warn_msg + | warn_if_true = addWarnTc warn_msg + | otherwise = return () + +addWarnTc :: MsgDoc -> TcM () addWarnTc msg = do { env0 <- tcInitTidyEnv ; addWarnTcM (env0, msg) } -addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM :: (TidyEnv, MsgDoc) -> TcM () addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; - addReport (ptext (sLit "Warning:") <+> msg) err_info } + add_warn msg err_info } -warnTc :: Bool -> Message -> TcM () -warnTc warn_if_true warn_msg - | warn_if_true = addWarnTc warn_msg - | otherwise = return () +addWarn :: MsgDoc -> TcRn () +addWarn msg = add_warn msg empty + +addWarnAt :: SrcSpan -> MsgDoc -> TcRn () +addWarnAt loc msg = add_warn_at loc msg empty + +add_warn :: MsgDoc -> MsgDoc -> TcRn () +add_warn msg extra_info + = do { loc <- getSrcSpanM + ; add_warn_at loc msg extra_info } + +add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at loc msg extra_info + = do { rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + reportWarning warn } \end{code} ----------------------------------- @@ -919,7 +942,7 @@ tcInitTidyEnv Other helper functions \begin{code} -add_err_tcm :: TidyEnv -> Message -> SrcSpan +add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt @@ -929,8 +952,8 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts - | opt_PprStyle_Debug -- In -dppr-debug style the output - = return empty -- just becomes too voluminous +-- | opt_PprStyle_Debug -- In -dppr-debug style the output +-- = return empty -- just becomes too voluminous | otherwise = go 0 env ctxts where @@ -976,6 +999,11 @@ addTcEvBind (EvBindsVar ev_ref _) var t = do { bnds <- readTcRef ev_ref ; writeTcRef ev_ref (extendEvBinds bnds var t) } +getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind) +getTcEvBinds (EvBindsVar ev_ref _) + = do { bnds <- readTcRef ev_ref + ; return (evBindMapBinds bnds) } + chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName chooseUniqueOccTc fn = do { env <- getGblEnv @@ -996,24 +1024,15 @@ emitConstraints ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`andWC` ct) } -emitFlat :: WantedEvVar -> TcM () +emitFlat :: Ct -> TcM () emitFlat ct = do { lie_var <- getConstraintVar ; updTcRef lie_var (`addFlats` unitBag ct) } -emitFlats :: Bag WantedEvVar -> TcM () -emitFlats ct +emitFlats :: Cts -> TcM () +emitFlats cts = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`addFlats` ct) } - -emitWantedCts :: Cts -> TcM () --- Precondition: all wanted -emitWantedCts = mapBagM_ emit_wanted_ct - where emit_wanted_ct ct - | v <- cc_id ct - , Wanted loc <- cc_flavor ct - = emitFlat (EvVarX v loc) - | otherwise = panic "emitWantedCts: can't emit non-wanted!" + updTcRef lie_var (`addFlats` cts) } emitImplication :: Implication -> TcM () emitImplication ct @@ -1196,7 +1215,7 @@ getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } -------------------- -failIfM :: Message -> IfL a +failIfM :: MsgDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldnt happen". -- We use IfL here so that we can get context info out of the local env diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 8b59a1224f..015510fb3f 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -54,15 +54,14 @@ module TcRnTypes( Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, singleCt, extendCts, isEmptyCts, isCTyEqCan, isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, - isCIrredEvCan, isCNonCanonical, - SubGoalDepth, ctPred, + isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, + isGivenCt_maybe, isGivenOrSolvedCt, + ctWantedLoc, + SubGoalDepth, mkNonCanonical, ctPred, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, addFlats, addImplics, mkFlatWC, - EvVarX(..), mkEvVarX, evVarOf, evVarX, evVarOfPred, - WantedEvVar, - Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), @@ -71,13 +70,15 @@ module TcRnTypes( SkolemInfo(..), - CtFlavor(..), pprFlavorArising, isWanted, - isGivenOrSolved, isGiven_maybe, isSolved, - isDerived, + CtFlavor(..), pprFlavorArising, + mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, + isWanted, isGivenOrSolved, isGiven_maybe, isSolved, + isDerived, getWantedLoc, canSolve, canRewrite, + combineCtLoc, -- Pretty printing - pprEvVarTheta, pprWantedEvVar, pprWantedsWithLocs, - pprEvVars, pprEvVarWithType, pprWantedEvVarWithLoc, + pprEvVarTheta, pprWantedsWithLocs, + pprEvVars, pprEvVarWithType, pprArising, pprArisingAt, -- Misc other types @@ -651,7 +652,7 @@ Note that: \begin{code} -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message)) +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -903,6 +904,8 @@ data Ct \end{code} \begin{code} +mkNonCanonical :: EvVar -> CtFlavor -> Ct +mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0} ctPred :: Ct -> PredType ctPred (CNonCanonical { cc_id = v }) = evVarPred v @@ -918,6 +921,57 @@ ctPred (CIrredEvCan { cc_ty = xi }) = xi \end{code} +%************************************************************************ +%* * + CtFlavor + The "flavor" of a canonical constraint +%* * +%************************************************************************ + +\begin{code} +ctWantedLoc :: Ct -> WantedLoc +-- Only works for Wanted/Derived +ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct ) + getWantedLoc (cc_flavor ct) + +isWantedCt :: Ct -> Bool +isWantedCt ct = isWanted (cc_flavor ct) + +isDerivedCt :: Ct -> Bool +isDerivedCt ct = isDerived (cc_flavor ct) + +isGivenCt_maybe :: Ct -> Maybe GivenKind +isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) + +isGivenOrSolvedCt :: Ct -> Bool +isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCIPCan_Maybe :: Ct -> Maybe (IPName Name) +isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm +isCIPCan_Maybe _ = Nothing + +isCIrredEvCan :: Ct -> Bool +isCIrredEvCan (CIrredEvCan {}) = True +isCIrredEvCan _ = False + +isCFunEqCan_Maybe :: Ct -> Maybe TyCon +isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc +isCFunEqCan_Maybe _ = Nothing + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False +\end{code} + \begin{code} instance Outputable Ct where ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct)) @@ -951,31 +1005,6 @@ emptyCts = emptyBag isEmptyCts :: Cts -> Bool isEmptyCts = isEmptyBag - -isCTyEqCan :: Ct -> Bool -isCTyEqCan (CTyEqCan {}) = True -isCTyEqCan (CFunEqCan {}) = False -isCTyEqCan _ = False - -isCDictCan_Maybe :: Ct -> Maybe Class -isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls -isCDictCan_Maybe _ = Nothing - -isCIPCan_Maybe :: Ct -> Maybe (IPName Name) -isCIPCan_Maybe (CIPCan {cc_ip_nm = nm }) = Just nm -isCIPCan_Maybe _ = Nothing - -isCIrredEvCan :: Ct -> Bool -isCIrredEvCan (CIrredEvCan {}) = True -isCIrredEvCan _ = False - -isCFunEqCan_Maybe :: Ct -> Maybe TyCon -isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc -isCFunEqCan_Maybe _ = Nothing - -isCNonCanonical :: Ct -> Bool -isCNonCanonical (CNonCanonical {}) = True -isCNonCanonical _ = False \end{code} %************************************************************************ @@ -992,7 +1021,7 @@ v%************************************************************************ \begin{code} data WantedConstraints - = WC { wc_flat :: Cts -- Unsolved constraints, all wanted + = WC { wc_flat :: Cts -- Unsolved constraints, all wanted , wc_impl :: Bag Implication , wc_insol :: Cts -- Insoluble constraints, can be -- wanted, given, or derived @@ -1022,12 +1051,9 @@ andWC (WC { wc_flat = f1, wc_impl = i1, wc_insol = n1 }) , wc_impl = i1 `unionBags` i2 , wc_insol = n1 `unionBags` n2 } -addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints -addFlats wc wevs +addFlats :: WantedConstraints -> Bag Ct -> WantedConstraints +addFlats wc cts = wc { wc_flat = wc_flat wc `unionBags` cts } - where cts = mapBag mk_noncan wevs - mk_noncan (EvVarX v wl) - = CNonCanonical { cc_id = v, cc_flavor = Wanted wl, cc_depth = 0} addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } @@ -1096,7 +1122,7 @@ data Implication -- However, we don't zonk ic_env when zonking the Implication -- Instead we do that when generating a skolem-escape error message - ic_skols :: TcTyVarSet, -- Introduced skolems + ic_skols :: [TcTyVar], -- Introduced skolems -- See Note [Skolems in an implication] ic_given :: [EvVar], -- Given evidence variables @@ -1163,38 +1189,11 @@ will be able to report a more informative error: %************************************************************************ %* * - EvVarX, WantedEvVar, FlavoredEvVar + Pretty printing %* * %************************************************************************ \begin{code} -data EvVarX a = EvVarX EvVar a - -- An evidence variable with accompanying info - -type WantedEvVar = EvVarX WantedLoc -- The location where it arose - - -instance Outputable (EvVarX a) where - ppr (EvVarX ev _) = pprEvVarWithType ev - -- If you want to see the associated info, - -- use a more specific printing function - -mkEvVarX :: EvVar -> a -> EvVarX a -mkEvVarX = EvVarX - -evVarOf :: EvVarX a -> EvVar -evVarOf (EvVarX ev _) = ev - -evVarX :: EvVarX a -> a -evVarX (EvVarX _ a) = a - -evVarOfPred :: EvVarX a -> PredType -evVarOfPred wev = evVarPred (evVarOf wev) - -\end{code} - - -\begin{code} pprEvVars :: [EvVar] -> SDoc -- Print with their types pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) @@ -1209,11 +1208,6 @@ pprWantedsWithLocs wcs = vcat [ pprBag ppr (wc_flat wcs) , pprBag ppr (wc_impl wcs) , pprBag ppr (wc_insol wcs) ] - -pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc -pprWantedEvVarWithLoc (EvVarX v loc) = hang (pprEvVarWithType v) - 2 (pprArisingAt loc) -pprWantedEvVar (EvVarX v _) = pprEvVarWithType v \end{code} %************************************************************************ @@ -1242,6 +1236,11 @@ instance Outputable CtFlavor where ppr (Wanted {}) = ptext (sLit "[W]") ppr (Derived {}) = ptext (sLit "[D]") +getWantedLoc :: CtFlavor -> WantedLoc +getWantedLoc (Wanted wl) = wl +getWantedLoc (Derived wl) = wl +getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav) + pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl @@ -1266,6 +1265,52 @@ isGiven_maybe _ = Nothing isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True isDerived _ = False + +canSolve :: CtFlavor -> CtFlavor -> Bool +-- canSolve ctid1 ctid2 +-- The constraint ctid1 can be used to solve ctid2 +-- "to solve" means a reaction where the active parts of the two constraints match. +-- active(F xis ~ xi) = F xis +-- active(tv ~ xi) = tv +-- active(D xis) = D xis +-- active(IP nm ty) = nm +-- +-- NB: either (a `canSolve` b) or (b `canSolve` a) must hold +----------------------------------------- +canSolve (Given {}) _ = True +canSolve (Wanted {}) (Derived {}) = True +canSolve (Wanted {}) (Wanted {}) = True +canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given +canSolve _ _ = False -- (There is no *evidence* for a derived.) + +canRewrite :: CtFlavor -> CtFlavor -> Bool +-- canRewrite ctid1 ctid2 +-- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +canRewrite = canSolve + +combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc +-- Precondition: At least one of them should be wanted +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc ) _ = loc +combineCtLoc _ (Derived loc ) = loc +combineCtLoc _ _ = panic "combineCtLoc: both given" + +mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor +-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) +mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) +mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl + +mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor +mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl + +mkWantedFlavor :: CtFlavor -> CtFlavor +mkWantedFlavor (Wanted loc) = Wanted loc +mkWantedFlavor (Derived loc) = Wanted loc +mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) \end{code} %************************************************************************ @@ -1355,7 +1400,8 @@ data SkolemInfo | BracketSkol -- Template Haskell bracket | UnifyForAllSkol -- We are unifying two for-all types - TcType + [TcTyVar] -- The instantiated skolem variables + TcType -- The instantiated type *inside* the forall | UnkSkol -- Unhelpful info (until I improve it) @@ -1385,7 +1431,7 @@ pprSkolInfo (PatSkol dc mc) = sep [ ptext (sLit "a pattern with constructor") pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of") , vcat [ ppr name <+> dcolon <+> ppr ty | (name,ty) <- ids ]] -pprSkolInfo (UnifyForAllSkol ty) = ptext (sLit "the type") <+> ppr ty +pprSkolInfo (UnifyForAllSkol tvs ty) = ptext (sLit "the type") <+> ppr (mkForAllTys tvs ty) -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 1106c92dba..240ba9c017 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -30,7 +30,7 @@ module TcSMonad ( canRewrite, canSolve, combineCtLoc, mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, - getWantedLoc, + ctWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality traceFireTcS, bumpStepCountTcS, doWithInert, @@ -600,82 +600,6 @@ extractRelevantInerts wi \end{code} - - -%************************************************************************ -%* * - CtFlavor - The "flavor" of a canonical constraint -%* * -%************************************************************************ - -\begin{code} -getWantedLoc :: Ct -> WantedLoc -getWantedLoc ct - = ASSERT (isWanted (cc_flavor ct)) - case cc_flavor ct of - Wanted wl -> wl - _ -> pprPanic "Can't get WantedLoc of non-wanted constraint!" empty - -isWantedCt :: Ct -> Bool -isWantedCt ct = isWanted (cc_flavor ct) -isDerivedCt :: Ct -> Bool -isDerivedCt ct = isDerived (cc_flavor ct) - -isGivenCt_maybe :: Ct -> Maybe GivenKind -isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) - -isGivenOrSolvedCt :: Ct -> Bool -isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) - - -canSolve :: CtFlavor -> CtFlavor -> Bool --- canSolve ctid1 ctid2 --- The constraint ctid1 can be used to solve ctid2 --- "to solve" means a reaction where the active parts of the two constraints match. --- active(F xis ~ xi) = F xis --- active(tv ~ xi) = tv --- active(D xis) = D xis --- active(IP nm ty) = nm --- --- NB: either (a `canSolve` b) or (b `canSolve` a) must hold ------------------------------------------ -canSolve (Given {}) _ = True -canSolve (Wanted {}) (Derived {}) = True -canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given -canSolve _ _ = False -- (There is no *evidence* for a derived.) - -canRewrite :: CtFlavor -> CtFlavor -> Bool --- canRewrite ctid1 ctid2 --- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 -canRewrite = canSolve - -combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc --- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc -combineCtLoc _ _ = panic "combineCtLoc: both given" - -mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor --- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) -mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl - -mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl - -mkWantedFlavor :: CtFlavor -> CtFlavor -mkWantedFlavor (Wanted loc) = Wanted loc -mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) -\end{code} - %************************************************************************ %* * %* The TcS solver monad * @@ -842,7 +766,7 @@ runTcS context untouch is wl tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_cache_var <- TcM.newTcRef $ EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM } - ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds + ; ev_binds_var <- TcM.newTcEvBinds ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef is @@ -871,8 +795,8 @@ runTcS context untouch is wl tcs <+> int count <+> ppr context) } -- And return - ; ev_binds <- TcM.readTcRef evb_ref - ; return (res, evBindMapBinds ev_binds) } + ; ev_binds <- TcM.getTcEvBinds ev_binds_var + ; return (res, ev_binds) } where do_unification (tv,ty) = TcM.writeMetaTyVar tv ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index e541b87fd0..7ef2549c25 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -40,6 +40,7 @@ import Control.Monad ( when ) import Outputable import FastString import TrieMap +import DynFlags \end{code} @@ -110,9 +111,9 @@ simplifyDeriv orig pred tvs theta ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) - ; (residual_wanted, _binds) - <- solveWanteds (SimplInfer doc) NoUntouchables $ - mkFlatWC wanted + ; (residual_wanted, _ev_binds1) + <- runTcS (SimplInfer doc) NoUntouchables emptyInert emptyWorkList $ + solveWanteds $ mkFlatWC wanted ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) -- See Note [Exotic derived instance contexts] @@ -121,7 +122,9 @@ simplifyDeriv orig pred tvs theta | otherwise = Right ct where p = ctPred ct - ; reportUnsolved (residual_wanted { wc_flat = bad }) + -- We never want to defer these errors because they are errors in the + -- compiler! Hence the `False` below + ; _ev_binds2 <- reportUnsolved False (residual_wanted { wc_flat = bad }) ; let min_theta = mkMinimalBySCs (bagToList good) ; return (substTheta subst_skol min_theta) } @@ -247,6 +250,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds = do { zonked_wanteds <- zonkWC wanteds ; zonked_taus <- zonkTcTypes (map snd name_taus) ; gbl_tvs <- tcGetGlobalTyVars + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; traceTc "simplifyInfer {" $ vcat [ ptext (sLit "names =") <+> ppr (map fst name_taus) @@ -274,46 +278,50 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds , ptext (sLit "surely_fref =") <+> ppr surely_free ] - ; emitWantedCts surely_free + ; emitFlats surely_free ; traceTc "sinf" $ vcat [ ptext (sLit "perhaps_bound =") <+> ppr perhaps_bound , ptext (sLit "surely_free =") <+> ppr surely_free ] -- Step 2 - -- Now simplify the possibly-bound constraints - ; (simpl_results, tc_binds0) - <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables emptyInert emptyWorkList $ - simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) - - ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint - (do { reportUnsolved simpl_results; failM }) + -- Now simplify the possibly-bound constraints + ; let ctxt = SimplInfer (ppr (map fst name_taus)) + ; (simpl_results, tc_binds) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) + + -- Fail fast if there is an insoluble constraint, + -- unless we are deferring errors to runtime + ; when (not runtimeCoercionErrors && insolubleWC simpl_results) $ + do { _ev_binds <- reportUnsolved False simpl_results + ; failM } -- Step 3 -- Split again simplified_perhaps_bound, because some unifications -- may have happened, and emit the free constraints. ; gbl_tvs <- tcGetGlobalTyVars ; zonked_tau_tvs <- zonkTcTyVarsAndFV zonked_tau_tvs - ; zonked_simples <- zonkCts (wc_flat simpl_results) + ; zonked_flats <- zonkCts (wc_flat simpl_results) ; let init_tvs = zonked_tau_tvs `minusVarSet` gbl_tvs - poly_qtvs = growWantedEVs gbl_tvs zonked_simples init_tvs - (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_simples + poly_qtvs = growWantedEVs gbl_tvs zonked_flats init_tvs + (pbound, pfree) = partitionBag (quantifyMe poly_qtvs) zonked_flats -- Monomorphism restriction mr_qtvs = init_tvs `minusVarSet` constrained_tvs - constrained_tvs = tyVarsOfCts zonked_simples + constrained_tvs = tyVarsOfCts zonked_flats mr_bites = apply_mr && not (isEmptyBag pbound) (qtvs, (bound, free)) - | mr_bites = (mr_qtvs, (emptyBag, zonked_simples)) + | mr_bites = (mr_qtvs, (emptyBag, zonked_flats)) | otherwise = (poly_qtvs, (pbound, pfree)) - ; emitWantedCts free + ; emitFlats free ; if isEmptyVarSet qtvs && isEmptyBag bound then ASSERT( isEmptyBag (wc_insol simpl_results) ) do { traceTc "} simplifyInfer/no quantification" empty ; emitImplications (wc_impl simpl_results) - ; return ([], [], mr_bites, EvBinds tc_binds0) } + ; return ([], [], mr_bites, EvBinds tc_binds) } else do -- Step 4, zonk quantified variables @@ -331,12 +339,13 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds -- Minimize `bound' and emit an implication ; minimal_bound_ev_vars <- mapM TcMType.newEvVar minimal_flat_preds ; ev_binds_var <- newTcEvBinds - ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) tc_binds0 + ; mapBagM_ (\(EvBind evar etrm) -> addTcEvBind ev_binds_var evar etrm) + tc_binds ; lcl_env <- getLclTypeEnv ; gloc <- getCtLoc skol_info ; let implic = Implic { ic_untch = NoUntouchables , ic_env = lcl_env - , ic_skols = mkVarSet qtvs_to_return + , ic_skols = qtvs_to_return , ic_given = minimal_bound_ev_vars , ic_wanted = simpl_results { wc_flat = bound } , ic_insol = False @@ -347,7 +356,7 @@ simplifyInfer _top_lvl apply_mr name_taus wanteds vcat [ ptext (sLit "implic =") <+> ppr implic -- ic_skols, ic_given give rest of result , ptext (sLit "qtvs =") <+> ppr qtvs_to_return - , ptext (sLit "spb =") <+> ppr zonked_simples + , ptext (sLit "spb =") <+> ppr zonked_flats , ptext (sLit "bound =") <+> ppr bound ] @@ -405,7 +414,7 @@ approximateImplications impls float_implic skols imp = (unitBag (imp { ic_wanted = wanted' }), floats) where - (wanted', floats) = float_wc (skols `unionVarSet` ic_skols imp) (ic_wanted imp) + (wanted', floats) = float_wc (skols `extendVarSetList` ic_skols imp) (ic_wanted imp) float_wc skols wc@(WC { wc_flat = flat, wc_impl = implic }) = (wc { wc_flat = flat', wc_impl = implic' }, floats1 `unionBags` floats2) @@ -444,7 +453,7 @@ growImplics gbl_tvs implics tvs = foldrBag grow_implic tvs implics where grow_implic implic tvs - = grow tvs `minusVarSet` ic_skols implic + = grow tvs `delVarSetList` ic_skols implic where grow = growWC gbl_tvs (ic_wanted implic) . growPreds gbl_tvs evVarPred (listToBag (ic_given implic)) @@ -568,7 +577,7 @@ Consider f :: (forall a. Eq a => a->a) -> Bool -> ... {-# RULES "foo" forall (v::forall b. Eq b => b->b). f b True = ... - #=} + #-} Here we *must* solve the wanted (Eq a) from the given (Eq a) resulting from skolemising the agument type of g. So we revert to SimplCheck when going under an implication. @@ -590,7 +599,8 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- solveWanteds (SimplRuleLhs name) untch zonked_lhs + <- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $ + solveWanteds zonked_lhs ; traceTc "simplifyRule" $ vcat [ text "zonked_lhs" <+> ppr zonked_lhs @@ -609,7 +619,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted ; ev_binds_var <- newTcEvBinds ; emitImplication $ Implic { ic_untch = untch , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = lhs_results { wc_flat = eqs } , ic_insol = insolubleWC lhs_results @@ -638,7 +648,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted , wc_impl = unitBag $ Implic { ic_untch = NoUntouchables , ic_env = emptyNameEnv - , ic_skols = mkVarSet tv_bndrs + , ic_skols = tv_bndrs , ic_given = lhs_dicts , ic_wanted = rhs_wanted , ic_insol = insolubleWC rhs_wanted @@ -680,29 +690,66 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck {" (vcat [ ptext (sLit "wanted =") <+> ppr wanteds ]) - ; (unsolved, ev_binds) <- - solveWanteds ctxt NoUntouchables wanteds + ; (unsolved, eb1) + <- runTcS ctxt NoUntouchables emptyInert emptyWorkList $ + solveWanteds wanteds + + ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved - ; traceTc "simplifyCheck }" $ - ptext (sLit "unsolved =") <+> ppr unsolved + -- See Note [Deferring coercion errors to runtime] + ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors + ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved + + ; return (eb1 `unionBags` eb2) } +\end{code} - ; reportUnsolved unsolved +Note [Deferring coercion errors to runtime] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ; return ev_binds } +While developing, sometimes it is desirable to allow compilation to succeed even +if there are type errors in the code. Consider the following case: ----------------- -solveWanteds :: SimplContext - -> Untouchables - -> WantedConstraints - -> TcM (WantedConstraints, Bag EvBind) + module Main where + + a :: Int + a = 'a' + + main = print "b" + +Even though `a` is ill-typed, it is not used in the end, so if all that we're +interested in is `main` it is handy to be able to ignore the problems in `a`. + +Since we treat type equalities as evidence, this is relatively simple. Whenever +we run into a type mismatch in TcUnify, we normally just emit an error. But it +is always safe to defer the mismatch to the main constraint solver. If we do +that, `a` will get transformed into + + co :: Int ~ Char + co = ... + + a :: Int + a = 'a' `cast` co + +The constraint solver would realize that `co` is an insoluble constraint, and +emit an error with `reportUnsolved`. But we can also replace the right-hand side +of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program +to compile, and it will run fine unless we evaluate `a`. This is what +`deferErrorsToRuntime` does. + +It does this by keeping track of which errors correspond to which coercion +in TcErrors (with ErrEnv). TcErrors.reportTidyWanteds does not print the errors +and does not fail if -fwarn-type-errors is on, so that we can continue +compilation. The errors are turned into warnings in `reportUnsolved`. + +\begin{code} +solveWanteds :: WantedConstraints -> TcS WantedConstraints -- Returns: residual constraints, plus evidence bindings -- NB: When we are called from TcM there are no inerts to pass down to TcS -solveWanteds ctxt untch wanted - = do { (wc_out, ev_binds) <- runTcS ctxt untch emptyInert emptyWorkList $ - solve_wanteds wanted +solveWanteds wanted + = do { wc_out <- solve_wanteds wanted ; let wc_ret = wc_out { wc_flat = keepWanted (wc_flat wc_out) } -- Discard Derived - ; return (wc_ret, ev_binds) } + ; return wc_ret } solve_wanteds :: WantedConstraints -> TcS WantedConstraints -- NB: wc_flats may be wanted *or* derived now @@ -874,7 +921,7 @@ solveImplication tcs_untouchables -- and we are back to the original inerts -floatEqualities :: TcTyVarSet -> [EvVar] -> Cts -> (Cts, Cts) +floatEqualities :: [TcTyVar] -> [EvVar] -> Cts -> (Cts, Cts) -- Post: The returned FlavoredEvVar's are only Wanted or Derived -- and come from the input wanted ev vars or deriveds floatEqualities skols can_given wantders @@ -882,11 +929,12 @@ floatEqualities skols can_given wantders -- Note [Float Equalities out of Implications] | otherwise = partitionBag is_floatable wantders - where is_floatable :: Ct -> Bool + where skol_set = mkVarSet skols + is_floatable :: Ct -> Bool is_floatable ct | ct_predty <- ctPred ct , isEqPred ct_predty - = skols `disjointVarSet` tvs_under_fsks ct_predty + = skol_set `disjointVarSet` tvs_under_fsks ct_predty is_floatable _ct = False tvs_under_fsks :: Type -> TyVarSet diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 757ef4442c..880d957718 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -748,7 +748,7 @@ deprecatedDollar quoter data MetaOps th_syn hs_syn = MT { mt_desc :: String -- Type of beast (expression, type etc) , mt_show :: th_syn -> String -- How to show the th_syn thing - , mt_cvt :: SrcSpan -> th_syn -> Either Message hs_syn + , mt_cvt :: SrcSpan -> th_syn -> Either MsgDoc hs_syn -- How to convert to hs_syn } @@ -801,7 +801,7 @@ runMetaD = runMetaQ declMetaOps --------------- runMeta :: (Outputable hs_syn) => Bool -- Whether code should be printed in the exception message - -> (SrcSpan -> x -> TcM (Either Message hs_syn)) -- How to run x + -> (SrcSpan -> x -> TcM (Either MsgDoc hs_syn)) -- How to run x -> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr @@ -902,8 +902,8 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where ; let i = getKey u ; return (TH.mkNameU s i) } - qReport True msg = addErr (text msg) - qReport False msg = addReport (text msg) empty + qReport True msg = addErr (text msg) + qReport False msg = addWarn (text msg) qLocation = do { m <- getModule ; l <- getSrcSpanM diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index aac60f578b..fb43f15d2e 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -58,7 +58,7 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, - eqKind, + pickyEqType, eqKind, isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, @@ -90,6 +90,7 @@ module TcType ( tidyOpenKind, tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, + tidyTyVarOcc, tidyTopType, tidyKind, tidyCo, tidyCos, @@ -475,7 +476,24 @@ tidyTyVarBndr tidy_env@(occ_env, subst) tyvar tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv -- ^ Add the free 'TyVar's to the env in tidy form, -- so that we can tidy the type they are free in -tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars)) +tidyFreeTyVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyVars (trimmed_occ_env, var_env) tv_list) + + where + tv_list = varSetElems tyvars + + trimmed_occ_env = foldr mk_occ_env emptyOccEnv tv_list + -- The idea here is that we restrict the new TidyEnv to the + -- _free_ vars of the type, so that we don't gratuitously rename + -- the _bound_ variables of the type + + mk_occ_env :: TyVar -> TidyOccEnv -> TidyOccEnv + mk_occ_env tv env + = case lookupOccEnv full_occ_env occ of + Just n -> extendOccEnv env occ n + Nothing -> env + where + occ = getOccName tv --------------- tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar]) @@ -492,27 +510,18 @@ tidyOpenTyVar env@(_, subst) tyvar Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder --------------- -tidyType :: TidyEnv -> Type -> Type -tidyType env@(_, subst) ty - = go ty +tidyTyVarOcc :: TidyEnv -> TyVar -> Type +tidyTyVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> expand tv + Just tv' -> expand tv' where - go (TyVarTy tv) = case lookupVarEnv subst tv of - Nothing -> expand tv - Just tv' -> expand tv' - go (TyConApp tycon tys) = let args = map go tys - in args `seqList` TyConApp tycon args - go (LitTy n) = LitTy n - go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg) - go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg) - go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) - where - (envp, tvp) = tidyTyVarBndr env tv - -- Expand FlatSkols, the skolems introduced by flattening process -- We don't want to show them in type error messages expand tv | isTcTyVar tv , FlatSkol ty <- tcTyVarDetails tv - = go ty + = WARN( True, text "I DON'T THINK THIS SHOULD EVER HAPPEN" <+> ppr tv <+> ppr ty ) + tidyType env ty | otherwise = TyVarTy tv @@ -521,6 +530,18 @@ tidyTypes :: TidyEnv -> [Type] -> [Type] tidyTypes env tys = map (tidyType env) tys --------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = tidyTyVarOcc env tv +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) + where + (envp, tvp) = tidyTyVarBndr env tv + +--------------- -- | Grabs the free type variables, tidies them -- and then uses 'tidyType' to work over the type itself tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) @@ -1009,7 +1030,25 @@ tcInstHeadTyAppAllTyVars ty get_tv _ = Nothing \end{code} - +\begin{code} +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +pickyEqType ty1 ty2 + = go init_env ty1 ty2 + where + init_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2)) + go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 + go env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = go (rnBndr2 env tv1 tv2) t1 t2 + go env (AppTy s1 t1) (AppTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 && go env t1 t2 + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) = (tc1 == tc2) && gos env ts1 ts2 + go _ _ _ = False + + gos _ [] [] = True + gos env (t1:ts1) (t2:ts2) = go env t1 t2 && gos env ts1 ts2 + gos _ _ _ = False +\end{code} %************************************************************************ %* * diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 71c372330f..566534c192 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -31,7 +31,7 @@ module TcUnify ( matchExpectedFunTys, matchExpectedFunKind, wrapFunResCoercion, - failWithMisMatch, + wrapEqCtxt, -------------------------------- -- Errors @@ -148,11 +148,6 @@ matchExpectedFunTys herald arity orig_ty = do { (co, tys, ty_r) <- go (n_req-1) res_ty ; return (mkTcFunCo (mkTcReflCo arg_ty) co, arg_ty:tys, ty_r) } - go _ (TyConApp tc _) -- A common case - | not (isSynFamilyTyCon tc) - = do { (env,msg) <- mk_ctxt emptyTidyEnv - ; failWithTcM (env,msg) } - go n_req ty@(TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv = do { cts <- readMetaTyVar tv @@ -172,7 +167,7 @@ matchExpectedFunTys herald arity orig_ty ; return (co, arg_tys, res_ty) } ------------ - mk_ctxt :: TidyEnv -> TcM (TidyEnv, Message) + mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc) mk_ctxt env = do { orig_ty1 <- zonkTcType orig_ty ; let (env', orig_ty2) = tidyOpenType env orig_ty1 (args, _) = tcSplitFunTys orig_ty2 @@ -449,7 +444,7 @@ newImplication skol_info skol_tvs given thing_inside ; loc <- getCtLoc skol_info ; emitImplication $ Implic { ic_untch = untch , ic_env = lcl_env - , ic_skols = mkVarSet skol_tvs + , ic_skols = skol_tvs , ic_given = given , ic_wanted = wanted , ic_insol = insolubleWC wanted @@ -536,11 +531,11 @@ uType, uType_np, uType_defer -------------- -- It is always safe to defer unification to the main constraint solver -- See Note [Deferred unification] -uType_defer (item : origin) ty1 ty2 - = wrapEqCtxt origin $ +uType_defer items ty1 ty2 + = ASSERT( not (null items) ) do { eqv <- newEq ty1 ty2 - ; loc <- getCtLoc (TypeEqOrigin item) - ; emitFlat (mkEvVarX eqv loc) + ; loc <- getCtLoc (TypeEqOrigin (last items)) + ; emitFlat (mkNonCanonical eqv (Wanted loc)) -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because @@ -549,11 +544,9 @@ uType_defer (item : origin) ty1 ty2 { ctxt <- getErrCtxt ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr eqv, ppr ty1, - ppr ty2, ppr origin, doc]) + ppr ty2, ppr items, doc]) } ; return (mkTcCoVarCo eqv) } -uType_defer [] _ _ - = panic "uType_defer" -------------- -- Push a new item on the origin stack (the most common case) @@ -572,9 +565,6 @@ uType_np origin orig_ty1 orig_ty2 else traceTc "u_tys yields coercion:" (ppr co) ; return co } where - bale_out :: [EqOrigin] -> TcM a - bale_out origin = failWithMisMatch origin - go :: TcType -> TcType -> TcM TcCoercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -583,8 +573,16 @@ uType_np origin orig_ty1 orig_ty2 -- Note that we pass in *original* (before synonym expansion), -- so that type variables tend to get filled in with -- the most informative version of the type - go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 - go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 + go (TyVarTy tv1) ty2 + = do { lookup_res <- lookupTcTyVar tv1 + ; case lookup_res of + Filled ty1 -> go ty1 ty2 + Unfilled ds1 -> uUnfilledVar origin NotSwapped tv1 ds1 ty2 } + go ty1 (TyVarTy tv2) + = do { lookup_res <- lookupTcTyVar tv2 + ; case lookup_res of + Filled ty2 -> go ty1 ty2 + Unfilled ds2 -> uUnfilledVar origin IsSwapped tv2 ds2 ty1 } -- See Note [Expanding synonyms during unification] -- @@ -612,8 +610,9 @@ uType_np origin orig_ty1 orig_ty2 | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2 go (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2 -- See Note [TyCon app] - = do { cos <- uList origin uType tys1 tys2 + -- See Note [Mismatched type lists and application decomposition] + | tc1 == tc2, length tys1 == length tys2 + = do { cos <- zipWithM (uType origin) tys1 tys2 ; return $ mkTcTyConAppCo tc1 cos } go (LitTy m) ty@(LitTy n) @@ -621,57 +620,55 @@ uType_np origin orig_ty1 orig_ty2 = return $ mkTcReflCo ty -- See Note [Care with type applications] - go (AppTy s1 t1) ty2 - | Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + -- Do not decompose FunTy against App; + -- it's often a type error, so leave it for the constraint solver + go (AppTy s1 t1) (AppTy s2 t2) + = go_app s1 t1 s2 t2 - go ty1 (AppTy s2 t2) - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 - = do { co_s <- uType_np origin s1 s2 - ; co_t <- uType origin t1 t2 - ; return $ mkTcAppCo co_s co_t } + go (AppTy s1 t1) (TyConApp tc2 ts2) + | Just (ts2', t2') <- snocView ts2 + = ASSERT( isDecomposableTyCon tc2 ) + go_app s1 t1 (TyConApp tc2 ts2') t2' + + go (TyConApp tc1 ts1) (AppTy s2 t2) + | Just (ts1', t1') <- snocView ts1 + = ASSERT( isDecomposableTyCon tc1 ) + go_app (TyConApp tc1 ts1') t1' s2 t2 go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 = unifySigmaTy origin ty1 ty2 -- Anything else fails - go _ _ = bale_out origin + go ty1 ty2 = uType_defer origin ty1 ty2 -- failWithMisMatch origin + + ------------------ + go_app s1 t1 s2 t2 + = do { co_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] + ; co_t <- uType origin t1 t2 + ; return $ mkTcAppCo co_s co_t } unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM TcCoercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 - ; unless (equalLength tvs1 tvs2) (failWithMisMatch origin) - ; skol_tvs <- tcInstSkolTyVars tvs1 + + ; defer_or_continue (not (equalLength tvs1 tvs2)) $ do { + skol_tvs <- tcInstSkolTyVars tvs1 -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs in_scope = mkInScopeSet (mkVarSet skol_tvs) phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 - skol_info = UnifyForAllSkol ty1 + skol_info = UnifyForAllSkol skol_tvs phi1 ; (ev_binds, co) <- checkConstraints skol_info skol_tvs [] $ uType origin phi1 phi2 - ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } - ---------------- -uList :: [EqOrigin] - -> ([EqOrigin] -> a -> a -> TcM b) - -> [a] -> [a] -> TcM [b] --- Unify corresponding elements of two lists of types, which --- should be of equal length. We charge down the list explicitly so that --- we can complain if their lengths differ. -uList _ _ [] [] = return [] -uList origin unify (ty1:tys1) (ty2:tys2) = do { x <- unify origin ty1 ty2; - ; xs <- uList origin unify tys1 tys2 - ; return (x:xs) } -uList origin _ _ _ = failWithMisMatch origin - -- See Note [Mismatched type lists and application decomposition] - + ; return (foldr mkTcForAllCo (TcLetCo ev_binds co) skol_tvs) } } + where + defer_or_continue True _ = uType_defer origin ty1 ty2 + defer_or_continue False m = m \end{code} Note [Care with type applications] @@ -683,7 +680,7 @@ so if one type is an App the other one jolly well better be too Note [Unifying AppTy] ~~~~~~~~~~~~~~~~~~~~~ -Considerm unifying (m Int) ~ (IO Int) where m is a unification variable +Consider unifying (m Int) ~ (IO Int) where m is a unification variable that is now bound to (say) (Bool ->). Then we want to report "Can't unify (Bool -> Int) with (IO Int) and not @@ -691,16 +688,6 @@ and not That is why we use the "_np" variant of uType, which does not alter the error message. -Note [TyCon app] -~~~~~~~~~~~~~~~~ -When we find two TyConApps, the argument lists are guaranteed equal -length. Reason: intially the kinds of the two types to be unified is -the same. The only way it can become not the same is when unifying two -AppTys (f1 a1)~(f2 a2). In that case there can't be a TyConApp in -the f1,f2 (because it'd absorb the app). If we unify f1~f2 first, -which we do, that ensures that f1,f2 have the same kind; and that -means a1,a2 have the same kind. And now the argument repeats. - Note [Mismatched type lists and application decomposition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we find two TyConApps, you might think that the argument lists @@ -769,20 +756,6 @@ of the substitution; rather, notice that @uVar@ (defined below) nips back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM TcCoercion -uVar origin swapped tv1 ty2 - = do { traceTc "uVar" (vcat [ ppr origin - , ppr swapped - , ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1) - , nest 2 (ptext (sLit " ~ ")) - , ppr ty2 <+> dcolon <+> ppr (typeKind ty2)]) - ; details <- lookupTcTyVar tv1 - ; case details of - Filled ty1 -> unSwap swapped (uType_np origin) ty1 ty2 - Unfilled details1 -> uUnfilledVar origin swapped tv1 details1 ty2 - } - ----------------- uUnfilledVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 @@ -928,15 +901,11 @@ checkTauTvUpdate tv ty Note [Avoid deferring] ~~~~~~~~~~~~~~~~~~~~~~ -We try to avoid creating deferred constraints for two reasons. - * First, efficiency. - * Second, currently we can only defer some constraints - under a forall. See unifySigmaTy. -So expanding synonyms here is a good thing to do. Example (Trac #4917) +We try to avoid creating deferred constraints only for efficiency. +Example (Trac #4917) a ~ Const a b where type Const a b = a. We can solve this immediately, even when -'a' is a skolem, just by expanding the synonym; and we should do so - in case this unification happens inside unifySigmaTy (sigh). +'a' is a skolem, just by expanding the synonym. Note [Type synonyms and the occur check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1046,29 +1015,6 @@ wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a -- comes from the outermost item wrapEqCtxt [] thing_inside = thing_inside wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside - ---------------- -failWithMisMatch :: [EqOrigin] -> TcM a --- Generate the message when two types fail to match, --- going to some trouble to make it helpful. --- We take the failing types from the top of the origin stack --- rather than reporting the particular ones we are looking --- at right now -failWithMisMatch (item:origin) - = wrapEqCtxt origin $ - do { ty_act <- zonkTcType (uo_actual item) - ; ty_exp <- zonkTcType (uo_expected item) - ; env0 <- tcInitTidyEnv - ; let (env1, pp_exp) = tidyOpenType env0 ty_exp - (env2, pp_act) = tidyOpenType env1 ty_act - ; failWithTcM (env2, misMatchMsg pp_act pp_exp) } -failWithMisMatch [] - = panic "failWithMisMatch" - -misMatchMsg :: TcType -> TcType -> SDoc -misMatchMsg ty_act ty_exp - = sep [ ptext (sLit "Couldn't match expected type") <+> quotes (ppr ty_exp) - , nest 12 $ ptext (sLit "with actual type") <+> quotes (ppr ty_act)] \end{code} @@ -1382,7 +1328,7 @@ These two context are used with checkSigTyVars \begin{code} sigCtxt :: Id -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> TcM (TidyEnv, Message) + -> TidyEnv -> TcM (TidyEnv, MsgDoc) sigCtxt id sig_tvs sig_theta sig_tau tidy_env = do actual_tau <- zonkTcType sig_tau let diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index ee0749a78a..1e99775906 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -454,7 +454,7 @@ where the 'Left b' indicates that 'b' can be freely instantiated. -- lookupUniqueInstEnv :: (InstEnv, InstEnv) -> Class -> [Type] - -> Either Message (ClsInst, [Type]) + -> Either MsgDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv instEnv cls tys of ([(inst, inst_tys)], _, _) diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 9a8cafc9ec..7d648aef7e 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -579,7 +579,7 @@ data BindFlag \begin{code} newtype UM a = UM { unUM :: (TyVar -> BindFlag) - -> MaybeErr Message a } + -> MaybeErr MsgDoc a } instance Monad UM where return a = UM (\_tvs -> Succeeded a) @@ -588,13 +588,13 @@ instance Monad UM where Failed err -> Failed err Succeeded v -> unUM (k v) tvs) -initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr Message a +initUM :: (TyVar -> BindFlag) -> UM a -> MaybeErr MsgDoc a initUM badtvs um = unUM um badtvs tvBindFlag :: TyVar -> UM BindFlag tvBindFlag tv = UM (\tv_fn -> Succeeded (tv_fn tv)) -failWith :: Message -> UM a +failWith :: MsgDoc -> UM a failWith msg = UM (\_tv_fn -> Failed msg) maybeErrToMaybe :: MaybeErr fail succ -> Maybe succ |