ghc-lib 9.2.1.20220109 → 9.2.2.20220307
raw patch · 75 files changed
+2279/−1131 lines, 75 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC/Cmm/CommonBlockElim.hs +4/−4
- compiler/GHC/Cmm/DebugBlock.hs +1/−1
- compiler/GHC/Cmm/Graph.hs +4/−3
- compiler/GHC/Cmm/Info.hs +7/−7
- compiler/GHC/Cmm/LayoutStack.hs +10/−6
- compiler/GHC/Cmm/Lint.hs +19/−2
- compiler/GHC/Cmm/Opt.hs +14/−4
- compiler/GHC/Cmm/Parser.y +5/−3
- compiler/GHC/Cmm/Ppr.hs +4/−1
- compiler/GHC/Cmm/Ppr/Expr.hs +6/−1
- compiler/GHC/Cmm/Sink.hs +7/−7
- compiler/GHC/Cmm/Utils.hs +16/−5
- compiler/GHC/CmmToAsm.hs +5/−5
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +300/−90
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +19/−6
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +10/−2
- compiler/GHC/CmmToAsm/PIC.hs +2/−1
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +13/−13
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +2/−1
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +35/−26
- compiler/GHC/CmmToC.hs +123/−21
- compiler/GHC/CmmToLlvm/CodeGen.hs +105/−76
- compiler/GHC/Core/Opt/DmdAnal.hs +153/−83
- compiler/GHC/Core/Opt/Pipeline.hs +11/−10
- compiler/GHC/Core/Opt/Simplify.hs +58/−27
- compiler/GHC/Core/Opt/Simplify/Utils.hs +73/−43
- compiler/GHC/Core/Opt/Specialise.hs +36/−0
- compiler/GHC/Core/Opt/WorkWrap.hs +26/−14
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +1/−1
- compiler/GHC/Core/Rules.hs +505/−198
- compiler/GHC/CoreToStg/Prep.hs +36/−29
- compiler/GHC/Driver/Main.hs +98/−14
- compiler/GHC/Driver/Make.hs +1/−45
- compiler/GHC/Driver/Pipeline.hs +9/−13
- compiler/GHC/HsToCore/Binds.hs +2/−2
- compiler/GHC/HsToCore/Coverage.hs +1/−5
- compiler/GHC/HsToCore/Pmc/Solver.hs +31/−17
- compiler/GHC/Iface/Load.hs +10/−3
- compiler/GHC/Iface/UpdateIdInfos.hs +0/−160
- compiler/GHC/IfaceToCore.hs +3/−2
- compiler/GHC/Linker/Static.hs +2/−1
- compiler/GHC/Llvm/Ppr.hs +17/−20
- compiler/GHC/Llvm/Syntax.hs +2/−2
- compiler/GHC/Stg/Debug.hs +8/−1
- compiler/GHC/StgToCmm/CgUtils.hs +2/−2
- compiler/GHC/StgToCmm/Foreign.hs +17/−19
- compiler/GHC/StgToCmm/Foreign.hs-boot +6/−0
- compiler/GHC/StgToCmm/Hpc.hs +1/−1
- compiler/GHC/StgToCmm/Layout.hs +1/−1
- compiler/GHC/StgToCmm/Monad.hs +7/−3
- compiler/GHC/StgToCmm/Prim.hs +149/−20
- compiler/GHC/StgToCmm/Prof.hs +4/−3
- compiler/GHC/StgToCmm/Ticky.hs +38/−21
- compiler/GHC/StgToCmm/Utils.hs +13/−9
- compiler/GHC/SysTools/Info.hs +1/−1
- compiler/GHC/Tc/Deriv/Generate.hs +20/−8
- compiler/GHC/Tc/Errors.hs +26/−2
- compiler/GHC/Tc/Gen/App.hs +18/−7
- compiler/GHC/Tc/Gen/Bind.hs +3/−0
- compiler/GHC/Tc/Gen/Head.hs +2/−0
- compiler/GHC/Tc/Gen/HsType.hs +20/−4
- compiler/GHC/Tc/Gen/Rule.hs +4/−3
- compiler/GHC/Tc/Solver.hs +79/−17
- compiler/GHC/Tc/Solver/Canonical.hs +2/−3
- compiler/GHC/Tc/Solver/Rewrite.hs +54/−19
- compiler/GHC/Tc/TyCl/Utils.hs +1/−1
- compiler/GHC/Tc/Utils/Instantiate.hs +2/−1
- compiler/GHC/Tc/Utils/Monad.hs +1/−2
- compiler/GHC/Tc/Utils/TcMType.hs +1/−1
- ghc-lib.cabal +2/−3
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
- ghc-lib/stage0/lib/ghcautoconf.h +8/−1
- ghc-lib/stage0/lib/settings +0/−1
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -144,7 +144,7 @@ hash_node :: CmmNode O x -> Word32 hash_node n | dont_care n = 0 -- don't care hash_node (CmmAssign r e) = hash_reg r + hash_e e- hash_node (CmmStore e e') = hash_e e + hash_e e'+ hash_node (CmmStore e e' _) = hash_e e + hash_e e' hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as hash_node (CmmBranch _) = 23 -- NB. ignore the label hash_node (CmmCondBranch p _ _ _) = hash_e p@@ -159,7 +159,7 @@ hash_e :: CmmExpr -> Word32 hash_e (CmmLit l) = hash_lit l- hash_e (CmmLoad e _) = 67 + hash_e e+ hash_e (CmmLoad e _ _) = 67 + hash_e e hash_e (CmmReg r) = hash_reg r hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check hash_e (CmmRegOff r i) = hash_reg r + cvt i@@ -210,7 +210,7 @@ -> CmmNode O O -> CmmNode O O -> Bool eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2) = r1 == r2 && eqExprWith eqBid e1 e2-eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)+eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _) = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1) (CmmUnsafeForeignCall t2 r2 a2)@@ -222,7 +222,7 @@ eqExprWith eqBid = eq where CmmLit l1 `eq` CmmLit l2 = eqLit l1 l2- CmmLoad e1 _ `eq` CmmLoad e2 _ = e1 `eq` e2+ CmmLoad e1 t1 a1 `eq` CmmLoad e2 t2 a2 = t1 `cmmEqType` t2 && e1 `eq` e2 && a1 == a2 CmmReg r1 `eq` CmmReg r2 = r1==r2 CmmRegOff r1 i1 `eq` CmmRegOff r2 i2 = r1==r2 && i1==i2 CmmMachOp op1 es1 `eq` CmmMachOp op2 es2 = op1==op2 && es1 `eqs` es2
compiler/GHC/Cmm/DebugBlock.hs view
@@ -546,7 +546,7 @@ toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0-toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)+toUnwindExpr platform (CmmLoad e _ _) = UwDeref (toUnwindExpr platform e) toUnwindExpr platform e@(CmmMachOp op [e1, e2]) = case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
compiler/GHC/Cmm/Graph.hs view
@@ -193,8 +193,9 @@ mkAssign l (CmmReg r) | l == r = mkNop mkAssign l r = mkMiddle $ CmmAssign l r +-- | Assumes natural alignment mkStore :: CmmExpr -> CmmExpr -> CmmAGraph-mkStore l r = mkMiddle $ CmmStore l r+mkStore l r = mkMiddle $ CmmStore l r NaturallyAligned ---------- Control transfer mkJump :: Profile -> Convention -> CmmExpr@@ -333,14 +334,14 @@ | isBitsType $ localRegType reg , typeWidth (localRegType reg) < wordWidth platform = let- stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))+ stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned local = CmmLocal reg width = cmmRegWidth platform local expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] in CmmAssign local expr | otherwise =- CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)+ CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty NaturallyAligned) where ty = localRegType reg init_offset = widthInBytes (wordWidth platform) -- infotable
compiler/GHC/Cmm/Info.hs view
@@ -461,8 +461,8 @@ -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr-closureInfoPtr opts e =- CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts)))+closureInfoPtr opts@(PtrOpts profile _) e =+ cmmLoadBWord (profilePlatform profile) (wordAligned opts e) -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -470,7 +470,7 @@ entryCode platform e = if platformTablesNextToCode platform then e- else CmmLoad e (bWord platform)+ else cmmLoadBWord platform e -- | Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table@@ -512,24 +512,24 @@ -- field of the info table infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr infoTableSrtBitmap profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile -- | Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType :: Profile -> CmmExpr -> CmmExpr infoTableClosureType profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile infoTablePtrs :: Profile -> CmmExpr -> CmmExpr infoTablePtrs profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr infoTableNonPtrs profile info_tbl- = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform) NaturallyAligned where platform = profilePlatform profile -- | Takes the info pointer of a function, and returns a pointer to the first
compiler/GHC/Cmm/LayoutStack.hs view
@@ -400,7 +400,7 @@ procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap procMiddle stackmaps node sm = case node of- CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)+ CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _ _) -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) } where loc = getStackLoc area off stackmaps CmmAssign (CmmLocal r) _other@@ -608,7 +608,8 @@ move (r,n) | Just (_,m) <- lookupUFM old_map r, n == m = [] | otherwise = [CmmStore (CmmStackSlot Old n)- (CmmReg (CmmLocal r))]+ (CmmReg (CmmLocal r))+ NaturallyAligned] @@ -707,7 +708,7 @@ futureContinuation :: Block CmmNode O O -> Maybe BlockId futureContinuation middle = foldBlockNodesB f middle Nothing where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId- f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _+ f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _)) _) _ = Just l f _ r = r @@ -756,6 +757,7 @@ select_save to_save (slot:stack) -> let assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r))+ NaturallyAligned n' = plusW platform n 1 in (to_save', stack', n', assig : assigs, (r,(r,n')):regs)@@ -790,6 +792,7 @@ n' = n + localRegBytes platform r assig = CmmStore (CmmStackSlot Old n') (CmmReg (CmmLocal r))+ NaturallyAligned trim_sp | not (null push_regs) = push_sp@@ -998,7 +1001,7 @@ go _stackmap [] = [] go stackmap (n:ns) = case n of- CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))+ CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) _ | Just (_,off) <- lookupUFM (sm_regs stackmap) r , area_off area + m == off -> go stackmap ns@@ -1088,7 +1091,8 @@ -- This cmmOffset basically corresponds to manifesting -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))- (localRegType reg))+ (localRegType reg)+ NaturallyAligned) | (reg, reg_off) <- stackSlotRegs stackmap , reg `elemRegSet` live ]@@ -1167,7 +1171,7 @@ -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. jump = CmmCall { cml_target = entryCode platform $- CmmLoad spExpr (bWord platform)+ cmmLoadBWord platform spExpr , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth platform)
compiler/GHC/Cmm/Lint.hs view
@@ -88,7 +88,7 @@ -- byte/word mismatches. lintCmmExpr :: CmmExpr -> CmmLint CmmType-lintCmmExpr (CmmLoad expr rep) = do+lintCmmExpr (CmmLoad expr rep _alignment) = do _ <- lintCmmExpr expr -- Disabled, if we have the inlining phase before the lint phase, -- we can have funny offsets due to pointer tagging. -- EZY@@ -98,6 +98,7 @@ lintCmmExpr expr@(CmmMachOp op args) = do platform <- getPlatform tys <- mapM lintCmmExpr args+ lintShiftOp op (zip args tys) if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op then cmmCheckMachOp op args tys else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)@@ -110,6 +111,22 @@ do platform <- getPlatform return (cmmExprType platform expr) +-- | Check for obviously out-of-bounds shift operations+lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()+lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]+ | isShiftOp op+ , n >= fromIntegral (widthInBits (typeWidth arg_ty))+ = cmmLintErr (text "Shift operation" <+> pprMachOp op+ <+> text "has out-of-range offset" <+> ppr n+ <> text ". This will result in undefined behavior")+lintShiftOp _ _ = return ()++isShiftOp :: MachOp -> Bool+isShiftOp (MO_Shl _) = True+isShiftOp (MO_U_Shr _) = True+isShiftOp (MO_S_Shr _) = True+isShiftOp _ = False+ -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys@@ -157,7 +174,7 @@ then return () else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty - CmmStore l r -> do+ CmmStore l r _alignment -> do _ <- lintCmmExpr l _ <- lintCmmExpr r return ()
compiler/GHC/Cmm/Opt.hs view
@@ -72,6 +72,16 @@ _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op +-- Eliminate shifts that are wider than the shiftee+cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)]+ | Just width <- isShift op+ , shift >= fromIntegral (widthInBits width)+ = Just $! CmmLit (CmmInt 0 width)+ where+ isShift (MO_Shl w) = Just w+ isShift (MO_U_Shr w) = Just w+ isShift (MO_S_Shr w) = Just w+ isShift _ = Nothing -- Eliminate conversion NOPs cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x@@ -134,16 +144,16 @@ MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r) MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r) MO_U_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem` y_u) r)- MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x `quot` y) r)- MO_S_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x `rem` y) r)+ MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r)+ MO_S_Rem r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `rem` y_s) r) MO_And r -> Just $! CmmLit (CmmInt (x .&. y) r) MO_Or r -> Just $! CmmLit (CmmInt (x .|. y) r) MO_Xor r -> Just $! CmmLit (CmmInt (x `xor` y) r) - MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+ MO_Shl r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r) MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)- MO_S_Shr r -> Just $! CmmLit (CmmInt (x `shiftR` fromIntegral y) r)+ MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r) _ -> Nothing
compiler/GHC/Cmm/Parser.y view
@@ -791,10 +791,13 @@ | STRING { do s <- code (newStringCLit $1); return (CmmLit s) } | reg { $1 }- | type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }+ | type dereference { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) } | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 } | '(' expr ')' { $2 } +dereference :: { CmmParse (AlignmentSpec, CmmExpr) }+ : '^' '[' expr ']' { do ptr <- $3; return (Unaligned, ptr) }+ | '[' expr ']' { do ptr <- $2; return (NaturallyAligned, ptr) } -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }@@ -1280,8 +1283,7 @@ mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph mkReturnSimple profile actuals updfr_off = mkReturn profile e actuals updfr_off- where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off)- (gcWord platform))+ where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off)) platform = profilePlatform profile doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
compiler/GHC/Cmm/Ppr.hs view
@@ -213,8 +213,11 @@ CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi -- rep[lv] = expr;- CmmStore lv expr -> rep <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi+ CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi where+ align_mark = case align of+ Unaligned -> text "^"+ NaturallyAligned -> empty rep = ppr ( cmmExprType platform expr ) -- call "ccall" foo(x, y)[r1, r2];
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -150,7 +150,12 @@ pprExpr9 platform e = case e of CmmLit lit -> pprLit1 platform lit- CmmLoad expr rep -> ppr rep <> brackets (pdoc platform expr)+ CmmLoad expr rep align+ -> let align_mark =+ case align of+ NaturallyAligned -> empty+ Unaligned -> text "^"+ in ppr rep <> align_mark <> brackets (pdoc platform expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
compiler/GHC/Cmm/Sink.hs view
@@ -580,9 +580,9 @@ use _ls _ z = z go :: LRegSet -> CmmExpr -> Bool -> Bool- go ls (CmmMachOp _ es) z = foldr (go ls) z es- go ls (CmmLoad addr _) z = go ls addr z- go ls e z = use ls e z+ go ls (CmmMachOp _ es) z = foldr (go ls) z es+ go ls (CmmLoad addr _ _) z = go ls addr z+ go ls e z = use ls e z -- we don't inline into CmmUnsafeForeignCall if the expression refers -- to global registers. This is a HACK to avoid global registers@@ -611,7 +611,7 @@ | foldRegsUsed platform (\b r' -> r == r' || b) False node = True -- (3) a store to an address conflicts with a read of the same memory- | CmmStore addr' e <- node+ | CmmStore addr' e _ <- node , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively@@ -786,9 +786,9 @@ memConflicts _ _ = True exprMem :: Platform -> CmmExpr -> AbsMem-exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)-exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)-exprMem _ _ = NoMem+exprMem platform (CmmLoad addr w _) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)+exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)+exprMem _ _ = NoMem loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w =
compiler/GHC/Cmm/Utils.hs view
@@ -31,6 +31,7 @@ cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB, cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW, cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+ cmmLoadBWord, cmmLoadGCWord, cmmNegate, cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord, cmmSLtWord,@@ -304,8 +305,17 @@ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)] cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr-cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty+cmmLoadIndex platform ty expr ix =+ CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses +-- | Load a naturally-aligned non-pointer word.+cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned++-- | Load a naturally-aligned GC pointer.+cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr+cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned+ -- The "B" variants take byte offsets cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr cmmRegOffB = cmmRegOff@@ -343,7 +353,8 @@ cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off) cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr-cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty+cmmLoadIndexW platform base off ty =+ CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,@@ -394,7 +405,7 @@ --------------------------------------------------- isTrivialCmmExpr :: CmmExpr -> Bool-isTrivialCmmExpr (CmmLoad _ _) = False+isTrivialCmmExpr (CmmLoad _ _ _) = False isTrivialCmmExpr (CmmMachOp _ _) = False isTrivialCmmExpr (CmmLit _) = True isTrivialCmmExpr (CmmReg _) = True@@ -402,7 +413,7 @@ isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" hasNoGlobalRegs :: CmmExpr -> Bool-hasNoGlobalRegs (CmmLoad e _) = hasNoGlobalRegs e+hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es hasNoGlobalRegs (CmmLit _) = True hasNoGlobalRegs (CmmReg (CmmLocal _)) = True@@ -474,7 +485,7 @@ regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool regUsedIn platform = regUsedIn_ where _ `regUsedIn_` CmmLit _ = False- reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e+ reg `regUsedIn_` CmmLoad e _ _ = reg `regUsedIn_` e reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg' reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg' reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
compiler/GHC/CmmToAsm.hs view
@@ -1044,10 +1044,10 @@ CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop") new_src -> CmmAssign reg new_src - CmmStore addr src+ CmmStore addr src align -> do addr' <- cmmExprConFold DataReference addr src' <- cmmExprConFold DataReference src- return $ CmmStore addr' src'+ return $ CmmStore addr' src' align CmmCall { cml_target = addr } -> do addr' <- cmmExprConFold JumpReference addr@@ -1088,7 +1088,7 @@ cmmExprNative referenceKind expr' cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr-cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep+cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align cmmExprCon config (CmmMachOp mop args) = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args) cmmExprCon _ other = other@@ -1101,9 +1101,9 @@ let platform = ncgPlatform config arch = platformArch platform case expr of- CmmLoad addr rep+ CmmLoad addr rep align -> do addr' <- cmmExprNative DataReference addr- return $ CmmLoad addr' rep+ return $ CmmLoad addr' rep align CmmMachOp mop args -> do args' <- mapM (cmmExprNative DataReference) args
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,4 +1,5 @@-{-# language GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-}@@ -11,9 +12,13 @@ where +#include "GhclibHsVersions.h"+ -- NCG stuff: import GHC.Prelude hiding (EQ) +import Data.Word+ import GHC.Platform.Regs import GHC.CmmToAsm.AArch64.Instr import GHC.CmmToAsm.AArch64.Regs@@ -49,8 +54,7 @@ import GHC.Data.OrdList import GHC.Utils.Outputable -import Control.Monad ( mapAndUnzipM, when, foldM )-import Data.Word+import Control.Monad ( mapAndUnzipM, foldM ) import Data.Maybe import GHC.Float @@ -288,7 +292,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _alignment | isFloatType ty -> assignMem_FltCode format addr src | otherwise -> assignMem_IntCode format addr src where ty = cmmExprType platform src@@ -396,13 +400,60 @@ litToImm' :: CmmLit -> NatM (Operand, InstrBlock) litToImm' lit = return (OpImm (litToImm lit), nilOL) - getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig getRegister' config (ncgPlatform config) e +-- | The register width to be used for an operation on the given width+-- operand.+opRegWidth :: Width -> Width+opRegWidth W64 = W64 -- x+opRegWidth W32 = W32 -- w+opRegWidth W16 = W32 -- w+opRegWidth W8 = W32 -- w+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to AArch64's 32-bit instruction variants+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some+-- care.+--+-- We handle 16-and 8-bit values by using the 32-bit operations and+-- sign-/zero-extending operands and truncate results as necessary. For+-- simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.+--+-- For instance, consider the program,+--+-- test(bits64 buffer)+-- bits8 a = bits8[buffer];+-- bits8 b = %mul(a, 42);+-- bits8 c = %not(b);+-- bits8 d = %shrl(c, 4::bits8);+-- return (d);+-- }+--+-- This program begins by loading `a` from memory, for which we use a+-- zero-extended byte-size load. We next sign-extend `a` to 32-bits, and use a+-- 32-bit multiplication to compute `b`, and truncate the result back down to+-- 8-bits.+--+-- Next we compute `c`: The `%not` requires no extension of its operands, but+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`+-- requires no extension and no truncate since we can assume that+-- `c` is zero-extended.+--+-- TODO:+-- Don't use Width in Operands+-- Instructions should rather carry a RegWidth+-- -- Note [Handling PIC on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- AArch64 does not have a special PIC register, the general approach is to -- simply go through the GOT, and there is assembly support for this: --@@ -451,9 +502,9 @@ return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) CmmInt i W8 -> do- return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowS W8 i))))))+ return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i)))))) CmmInt i W16 -> do- return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowS W16 i))))))+ return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i)))))) -- We need to be careful to not shorten this for negative literals. -- Those need the upper bits set. We'd either have to explicitly sign@@ -549,8 +600,8 @@ CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr) CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)- CmmLoad mem rep -> do- Amode addr addr_code <- getAmode plat mem+ CmmLoad mem rep _ -> do+ Amode addr addr_code <- getAmode plat (typeWidth rep) mem let format = cmmTypeFormat rep return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr))) CmmStackSlot _ _@@ -577,9 +628,13 @@ CmmMachOp op [e] -> do (reg, _format, code) <- getSomeReg e case op of- MO_Not w -> return $ Any (intFormat w) (\dst -> code `snocOL` MVN (OpReg w dst) (OpReg w reg))+ MO_Not w -> return $ Any (intFormat w) $ \dst ->+ let w' = opRegWidth w+ in code `snocOL`+ MVN (OpReg w' dst) (OpReg w' reg) `appOL`+ truncateReg w' w dst -- See Note [Signed arithmetic on AArch64] - MO_S_Neg w -> return $ Any (intFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))+ MO_S_Neg w -> negate code w reg MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg)) MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)@@ -589,20 +644,41 @@ -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@ -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend). MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))- MO_SS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` SBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))+ MO_SS_Conv from to -> ss_conv from to reg code MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg)) -- Conversions MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)- where toImm W8 = (OpImm (ImmInt 7))- toImm W16 = (OpImm (ImmInt 15))- toImm W32 = (OpImm (ImmInt 31))- toImm W64 = (OpImm (ImmInt 63))- toImm W128 = (OpImm (ImmInt 127))- toImm W256 = (OpImm (ImmInt 255))- toImm W512 = (OpImm (ImmInt 511))+ where+ toImm W8 = (OpImm (ImmInt 7))+ toImm W16 = (OpImm (ImmInt 15))+ toImm W32 = (OpImm (ImmInt 31))+ toImm W64 = (OpImm (ImmInt 63))+ toImm W128 = (OpImm (ImmInt 127))+ toImm W256 = (OpImm (ImmInt 255))+ toImm W512 = (OpImm (ImmInt 511))++ -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+ -- See Note [Signed arithmetic on AArch64].+ negate code w reg = do+ let w' = opRegWidth w+ return $ Any (intFormat w) $ \dst ->+ code `appOL`+ signExtendReg w w' reg `snocOL`+ NEG (OpReg w' dst) (OpReg w' reg) `appOL`+ truncateReg w' w dst++ ss_conv from to reg code =+ let w' = opRegWidth (max from to)+ in return $ Any (intFormat to) $ \dst ->+ code `snocOL`+ SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`+ -- At this point an 8- or 16-bit value would be sign-extended+ -- to 32-bits. Truncate back down the final width.+ truncateReg w' to dst+ -- Dyadic machops: -- -- The general idea is:@@ -629,6 +705,15 @@ where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) r' = getRegisterReg plat reg + CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ -- 2. Shifts. x << n, x >> n. CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do (reg_x, _format_x, code_x) <- getSomeReg x@@ -637,9 +722,51 @@ (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) + CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+ CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++ CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+ CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++ CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++ CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+++ CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+ CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++ CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+ CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+ CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+ CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do (reg_x, _format_x, code_x) <- getSomeReg x return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))@@ -658,40 +785,75 @@ -- Generic case. CmmMachOp op [x, y] -> do -- alright, so we have an operation, and two expressions. And we want to essentially do- -- ensure we get float regs- let genOp w op = do- (reg_x, format_x, code_x) <- getSomeReg x- (reg_y, format_y, code_y) <- getSomeReg y- when ((isFloatFormat format_x && isIntFormat format_y) || (isIntFormat format_x && isFloatFormat format_y)) $ pprPanic "getRegister:genOp" (text "formats don't match:" <+> text (show format_x) <+> text "/=" <+> text (show format_y))- return $ Any format_x (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))-- withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op+ -- ensure we get float regs (TODO(Ben): What?)+ let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op - intOp w op = do+ -- A "plain" operation.+ bitOp w op = do -- compute x<m> <- x -- compute x<o> <- y -- <OP> x<n>, x<m>, x<o>- (reg_x, _format_x, code_x) <- getSomeReg x- (reg_y, _format_y, code_y) <- getSomeReg y- return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+ (reg_x, format_x, code_x) <- getSomeReg x+ (reg_y, format_y, code_y) <- getSomeReg y+ MASSERT2(isIntFormat format_x == isIntFormat format_y, text "bitOp: incompatible")+ return $ Any (intFormat w) (\dst ->+ code_x `appOL`+ code_y `appOL`+ op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))++ -- A (potentially signed) integer operation.+ -- In the case of 8- and 16-bit signed arithmetic we must first+ -- sign-extend both arguments to 32-bits.+ -- See Note [Signed arithmetic on AArch64].+ intOp is_signed w op = do+ -- compute x<m> <- x+ -- compute x<o> <- y+ -- <OP> x<n>, x<m>, x<o>+ (reg_x, format_x, code_x) <- getSomeReg x+ (reg_y, format_y, code_y) <- getSomeReg y+ MASSERT2(isIntFormat format_x && isIntFormat format_y, text "intOp: non-int")+ -- This is the width of the registers on which the operation+ -- should be performed.+ let w' = opRegWidth w+ signExt r+ | not is_signed = nilOL+ | otherwise = signExtendReg w w' r+ return $ Any (intFormat w) $ \dst ->+ code_x `appOL`+ code_y `appOL`+ -- sign-extend both operands+ signExt reg_x `appOL`+ signExt reg_y `appOL`+ op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+ truncateReg w' w dst -- truncate back to the operand's original width+ floatOp w op = do- (reg_fx, _format_x, code_fx) <- getFloatReg x- (reg_fy, _format_y, code_fy) <- getFloatReg y+ (reg_fx, format_x, code_fx) <- getFloatReg x+ (reg_fy, format_y, code_fy) <- getFloatReg y+ MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatOp: non-float") return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))+ -- need a special one for conditionals, as they return ints floatCond w op = do- (reg_fx, _format_x, code_fx) <- getFloatReg x- (reg_fy, _format_y, code_fy) <- getFloatReg y+ (reg_fx, format_x, code_fx) <- getFloatReg x+ (reg_fy, format_y, code_fy) <- getFloatReg y+ MASSERT2(isFloatFormat format_x && isFloatFormat format_y, text "floatCond: non-float") return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)) case op of -- Integer operations- -- Add/Sub should only be Interger Options.- -- But our Cmm parser doesn't care about types- -- and thus we end up with <float> + <float> => MO_Add <float> <float>- MO_Add w -> genOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))- MO_Sub w -> genOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+ -- Add/Sub should only be Integer Options.+ MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))+ -- TODO: Handle sub-word case+ MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))++ -- Note [CSET]+ --+ -- Setting conditional flags: the architecture internally knows the+ -- following flag bits. And based on thsoe comparisons as in the+ -- table below.+ -- -- 31 30 29 28 -- .---+---+---+---+-- - - -- | N | Z | C | V |@@ -724,13 +886,15 @@ -- | NV | Never | Any | 1111 | --- '-------------------------------------------------------------------------' - MO_Eq w -> intOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])- MO_Ne w -> intOp w (\d x y -> toOL [ CMP x y, CSET d NE ])- MO_Mul w -> intOp w (\d x y -> unitOL $ MUL d x y)+ -- N.B. We needn't sign-extend sub-word size (in)equality comparisons+ -- since we don't care about ordering.+ MO_Eq w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])+ MO_Ne w -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ]) -- Signed multiply/divide- MO_S_MulMayOflo w -> intOp w (\d x y -> toOL [ MUL d x y, CSET d VS ])- MO_S_Quot w -> intOp w (\d x y -> unitOL $ SDIV d x y)+ MO_Mul w -> intOp True w (\d x y -> unitOL $ MUL d x y)+ MO_S_MulMayOflo w -> intOp True w (\d x y -> toOL [ MUL d x y, CSET d VS ])+ MO_S_Quot w -> intOp True w (\d x y -> unitOL $ SDIV d x y) -- No native rem instruction. So we'll compute the following -- Rd <- Rx / Ry | 2 <- 7 / 3 -- SDIV Rd Rx Ry@@ -740,25 +904,25 @@ -- '--------------------------' -- Note the swap in Rx and Ry. MO_S_Rem w -> withTempIntReg w $ \t ->- intOp w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])+ intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ]) -- Unsigned multiply/divide MO_U_MulMayOflo _w -> unsupportedP plat expr- MO_U_Quot w -> intOp w (\d x y -> unitOL $ UDIV d x y)+ MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y) MO_U_Rem w -> withTempIntReg w $ \t ->- intOp w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])+ intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ]) - -- Signed comparisons -- see above for the CSET discussion- MO_S_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGE ])- MO_S_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLE ])- MO_S_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGT ])- MO_S_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLT ])+ -- Signed comparisons -- see Note [CSET]+ MO_S_Ge w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGE ])+ MO_S_Le w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLE ])+ MO_S_Gt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SGT ])+ MO_S_Lt w -> intOp True w (\d x y -> toOL [ CMP x y, CSET d SLT ]) -- Unsigned comparisons- MO_U_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGE ])- MO_U_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULE ])- MO_U_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGT ])- MO_U_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULT ])+ MO_U_Ge w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])+ MO_U_Le w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])+ MO_U_Gt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])+ MO_U_Lt w -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) -- Floating point arithmetic MO_F_Add w -> floatOp w (\d x y -> unitOL $ ADD d x y)@@ -781,13 +945,12 @@ MO_F_Lt w -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x -- Bitwise operations- MO_And w -> intOp w (\d x y -> unitOL $ AND d x y)- MO_Or w -> intOp w (\d x y -> unitOL $ ORR d x y)- MO_Xor w -> intOp w (\d x y -> unitOL $ EOR d x y)- -- MO_Not W64 ->- MO_Shl w -> intOp w (\d x y -> unitOL $ LSL d x y)- MO_U_Shr w -> intOp w (\d x y -> unitOL $ LSR d x y)- MO_S_Shr w -> intOp w (\d x y -> unitOL $ ASR d x y)+ MO_And w -> bitOp w (\d x y -> unitOL $ AND d x y)+ MO_Or w -> bitOp w (\d x y -> unitOL $ ORR d x y)+ MO_Xor w -> bitOp w (\d x y -> unitOL $ EOR d x y)+ MO_Shl w -> intOp False w (\d x y -> unitOL $ LSL d x y)+ MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)+ MO_S_Shr w -> intOp True w (\d x y -> unitOL $ ASR d x y) -- TODO @@ -816,29 +979,58 @@ ,0b1111_1111] +-- | Instructions to sign-extend the value in the given register from width @w@+-- up to width @w'@.+signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg w w' r =+ case w of+ W64 -> nilOL+ W32+ | w' == W32 -> nilOL+ | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+ W16 -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)+ W8 -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+ _ -> panic "intOp"++-- | Instructions to truncate the value in the given register from width @w@+-- down to width @w'@.+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg w w' r =+ case w of+ W64 -> nilOL+ W32+ | w' == W32 -> nilOL+ _ -> unitOL $ UBFM (OpReg w r)+ (OpReg w r)+ (OpImm (ImmInt 0))+ (OpImm $ ImmInt $ widthInBits w' - 1)+ -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. data Amode = Amode AddrMode InstrBlock -getAmode :: Platform -> CmmExpr -> NatM Amode+getAmode :: Platform+ -> Width -- ^ width of loaded value+ -> CmmExpr+ -> NatM Amode -- TODO: Specialize stuff we can destructure here. -- OPTIMIZATION WARNING: Addressing modes. -- Addressing options: -- LDUR/STUR: imm9: -256 - 255-getAmode platform (CmmRegOff reg off) | -256 <= off, off <= 255+getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4-getAmode platform (CmmRegOff reg off)- | typeWidth (cmmRegType platform reg) == W32, 0 <= off, off <= 16380, off `mod` 4 == 0+getAmode platform W32 (CmmRegOff reg off)+ | 0 <= off, off <= 16380, off `mod` 4 == 0 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8-getAmode platform (CmmRegOff reg off)- | typeWidth (cmmRegType platform reg) == W64, 0 <= off, off <= 32760, off `mod` 8 == 0+getAmode platform W64 (CmmRegOff reg off)+ | 0 <= off, off <= 32760, off `mod` 8 == 0 = return $ Amode (AddrRegImm reg' off') nilOL where reg' = getRegisterReg platform reg off' = ImmInt off@@ -847,18 +1039,18 @@ -- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) -- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] -- for `n` in range.-getAmode _platform (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')]) | -256 <= off, off <= 255 = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrRegImm reg (ImmInteger off)) code -getAmode _platform (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')]) | -256 <= -off, -off <= 255 = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrRegImm reg (ImmInteger (-off))) code -- Generic case-getAmode _platform expr+getAmode _platform _ expr = do (reg, _format, code) <- getSomeReg expr return $ Amode (AddrReg reg) code @@ -884,11 +1076,12 @@ = do (src_reg, _format, code) <- getSomeReg srcE platform <- getPlatform- Amode addr addr_code <- getAmode platform addrE+ let w = formatToWidth rep+ Amode addr addr_code <- getAmode platform w addrE return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE))) `consOL` (code `appOL` addr_code- `snocOL` STR rep (OpReg (formatToWidth rep) src_reg) (OpAddr addr))+ `snocOL` STR rep (OpReg w src_reg) (OpAddr addr)) assignReg_IntCode _ reg src = do@@ -940,11 +1133,28 @@ -- Generic case. CmmMachOp mop [x, y] -> do - let bcond w cmp = do- -- compute both sides.- (reg_x, _format_x, code_x) <- getSomeReg x- (reg_y, _format_y, code_y) <- getSomeReg y- return $ code_x `appOL` code_y `snocOL` CMP (OpReg w reg_x) (OpReg w reg_y) `snocOL` (annExpr expr (BCOND cmp (TBlock bid)))+ let ubcond w cmp = do+ -- compute both sides.+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ let x' = OpReg w reg_x+ y' = OpReg w reg_y+ return $ case w of+ W8 -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+ W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+ _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]++ sbcond w cmp = do+ -- compute both sides.+ (reg_x, _format_x, code_x) <- getSomeReg x+ (reg_y, _format_y, code_y) <- getSomeReg y+ let x' = OpReg w reg_x+ y' = OpReg w reg_y+ return $ case w of+ W8 -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+ W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+ _ -> code_x `appOL` code_y `appOL` toOL [ CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+ fbcond w cmp = do -- ensure we get float regs (reg_fx, _format_fx, code_fx) <- getFloatReg x@@ -960,17 +1170,17 @@ MO_F_Lt w -> fbcond w OLT MO_F_Le w -> fbcond w OLE - MO_Eq w -> bcond w EQ- MO_Ne w -> bcond w NE+ MO_Eq w -> sbcond w EQ+ MO_Ne w -> sbcond w NE - MO_S_Gt w -> bcond w SGT- MO_S_Ge w -> bcond w SGE- MO_S_Lt w -> bcond w SLT- MO_S_Le w -> bcond w SLE- MO_U_Gt w -> bcond w UGT- MO_U_Ge w -> bcond w UGE- MO_U_Lt w -> bcond w ULT- MO_U_Le w -> bcond w ULE+ MO_S_Gt w -> sbcond w SGT+ MO_S_Ge w -> sbcond w SGE+ MO_S_Lt w -> sbcond w SLT+ MO_S_Le w -> sbcond w SLE+ MO_U_Gt w -> ubcond w UGT+ MO_U_Ge w -> ubcond w UGE+ MO_U_Lt w -> ubcond w ULT+ MO_U_Le w -> ubcond w ULE _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr) _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -87,7 +87,12 @@ -- 2. Bit Manipulation Instructions ------------------------------------------ SBFM dst src _ _ -> usage (regOp src, regOp dst) UBFM dst src _ _ -> usage (regOp src, regOp dst)-+ SBFX dst src _ _ -> usage (regOp src, regOp dst)+ UBFX dst src _ _ -> usage (regOp src, regOp dst)+ SXTB dst src -> usage (regOp src, regOp dst)+ UXTB dst src -> usage (regOp src, regOp dst)+ SXTH dst src -> usage (regOp src, regOp dst)+ UXTH dst src -> usage (regOp src, regOp dst) -- 3. Logical and Move Instructions ------------------------------------------ AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) ASR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -211,6 +216,12 @@ -- 2. Bit Manipulation Instructions ---------------------------------------- SBFM o1 o2 o3 o4 -> SBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4) UBFM o1 o2 o3 o4 -> UBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+ SBFX o1 o2 o3 o4 -> SBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+ UBFX o1 o2 o3 o4 -> UBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+ SXTB o1 o2 -> SXTB (patchOp o1) (patchOp o2)+ UXTB o1 o2 -> UXTB (patchOp o1) (patchOp o2)+ SXTH o1 o2 -> SXTH (patchOp o1) (patchOp o2)+ UXTH o1 o2 -> UXTH (patchOp o1) (patchOp o2) -- 3. Logical and Move Instructions ---------------------------------------- AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)@@ -520,11 +531,10 @@ | DELTA Int -- 0. Pseudo Instructions --------------------------------------------------- -- These are instructions not contained or only partially contained in the- -- official ISA, but make reading clearer. Some of them might even be- -- implemented in the assembler, but are not guaranteed to be portable.- -- | SXTB Operand Operand- -- | SXTH Operand Operand+ | SXTB Operand Operand+ | UXTB Operand Operand+ | SXTH Operand Operand+ | UXTH Operand Operand -- | SXTW Operand Operand -- | SXTX Operand Operand | PUSH_STACK_FRAME@@ -571,6 +581,9 @@ | UBFM Operand Operand Operand Operand -- rd = rn[i,j] -- UXTB = UBFM <Wd>, <Wn>, #0, #7 -- UXTH = UBFM <Wd>, <Wn>, #0, #15+ -- Signed/Unsigned bitfield extract+ | SBFX Operand Operand Operand Operand -- rd = rn[i,j]+ | UBFX Operand Operand Operand Operand -- rd = rn[i,j] -- 3. Logical and Move Instructions ---------------------------------------- | AND Operand Operand Operand -- rd = rn & op2
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -423,6 +423,14 @@ -- 2. Bit Manipulation Instructions ------------------------------------------ SBFM o1 o2 o3 o4 -> text "\tsbfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4 UBFM o1 o2 o3 o4 -> text "\tubfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+ -- signed and unsigned bitfield extract+ SBFX o1 o2 o3 o4 -> text "\tsbfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+ UBFX o1 o2 o3 o4 -> text "\tubfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+ SXTB o1 o2 -> text "\tsxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ UXTB o1 o2 -> text "\tuxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ SXTH o1 o2 -> text "\tsxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ UXTH o1 o2 -> text "\tuxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ -- 3. Logical and Move Instructions ------------------------------------------ AND o1 o2 o3 -> text "\tand" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 ANDS o1 o2 o3 -> text "\tands" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3@@ -536,9 +544,9 @@ #endif LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->- text "\tldrsb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ text "\tldrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2 LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->- text "\tldrsh" <+> pprOp platform o1 <> comma <+> pprOp platform o2+ text "\tldrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2 LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
compiler/GHC/CmmToAsm/PIC.hs view
@@ -63,6 +63,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm import GHC.Cmm.CLabel+import GHC.Cmm.Utils (cmmLoadBWord) import GHC.Types.Basic @@ -134,7 +135,7 @@ AccessViaSymbolPtr -> do let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl addImport symbolPtr- return $ CmmLoad (cmmMakePicReference config symbolPtr) (bWord platform)+ return $ cmmLoadBWord platform (cmmMakePicReference config symbolPtr) AccessDirectly -> case referenceKind of -- for data, we might have to make some calculations:
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -177,7 +177,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _alignment | isFloatType ty -> assignMem_FltCode format addr src | target32Bit platform && isWord64 ty -> assignMem_I64Code addr src@@ -341,7 +341,7 @@ iselExpr64 :: CmmExpr -> NatM ChildCode64-iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree (rlo, rhi) <- getNewRegPairNat II32 let mov_hi = LD II32 rhi hi_addr@@ -465,7 +465,7 @@ ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister' _ platform (CmmLoad mem pk)+getRegister' _ platform (CmmLoad mem pk _) | not (isWord64 pk) = do Amode addr addr_code <- getAmode D mem let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)@@ -479,45 +479,45 @@ where format = cmmTypeFormat pk -- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr)) -- Note: there is no Load Byte Arithmetic instruction, so no signed case here -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do Amode addr addr_code <- getAmode D mem return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr)) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do -- lwa is DS-form. See Note [Power instruction format] Amode addr addr_code <- getAmode DS mem return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -138,7 +138,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _ | isFloatType ty -> assignMem_FltCode format addr src | isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode format addr src
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs view
@@ -235,7 +235,7 @@ _ -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop) -getRegister (CmmLoad mem pk) = do+getRegister (CmmLoad mem pk _) = do Amode src code <- getAmode mem let code__2 dst = code `snocOL` LD (cmmTypeFormat pk) src dst
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view
@@ -88,7 +88,8 @@ iselExpr64 :: CmmExpr -> NatM ChildCode64 -- Load a 64 bit word-iselExpr64 (CmmLoad addrTree ty)+-- TODO: Check Ben+iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do Amode amode addr_code <- getAmode addrTree let result
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -341,7 +341,7 @@ where ty = cmmRegType platform reg format = cmmTypeFormat ty - CmmStore addr src+ CmmStore addr src _alignment | isFloatType ty -> assignMem_FltCode format addr src | is32Bit && isWord64 ty -> assignMem_I64Code addr src | otherwise -> assignMem_IntCode format addr src@@ -529,7 +529,7 @@ ] return (ChildCode64 code rlo) -iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do Amode addr addr_code <- getAmode addrTree (rlo,rhi) <- getNewRegPairNat II32 let@@ -695,49 +695,49 @@ loadFloatAmode w addr code -- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do code <- intLoadCode (MOVZxL II8) addr return (Any II32 code) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do code <- intLoadCode (MOVSxL II8) addr return (Any II32 code) -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do code <- intLoadCode (MOVZxL II16) addr return (Any II32 code) -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do code <- intLoadCode (MOVSxL II16) addr return (Any II32 code) -- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOVZxL II8) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOVSxL II8) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOVZxL II16) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOVSxL II16) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _]) | not is32Bit = do code <- intLoadCode (MOVSxL II32) addr return (Any II64 code)@@ -1004,7 +1004,16 @@ -> NatM Register {- Case1: shift length as immediate -}- shift_code width instr x (CmmLit lit) = do+ shift_code width instr x (CmmLit lit)+ -- Handle the case of a shift larger than the width of the shifted value.+ -- This is necessary since x86 applies a mask of 0x1f to the shift+ -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+ -- `47 & 0x1f == 15`. See #20626.+ | CmmInt n _ <- lit+ , n >= fromIntegral (widthInBits width)+ = getRegister $ CmmLit $ CmmInt 0 width++ | otherwise = do x_code <- getAnyReg x let format = intFormat width@@ -1108,13 +1117,13 @@ return (Fixed format result code) -getRegister' _ _ (CmmLoad mem pk)+getRegister' _ _ (CmmLoad mem pk _) | isFloatType pk = do Amode addr mem_code <- getAmode mem loadFloatAmode (typeWidth pk) addr mem_code -getRegister' _ is32Bit (CmmLoad mem pk)+getRegister' _ is32Bit (CmmLoad mem pk _) | is32Bit && not (isWord64 pk) = do code <- intLoadCode instr mem@@ -1132,7 +1141,7 @@ -- simpler we do our 8-bit arithmetic with full 32-bit registers. -- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk)+getRegister' _ is32Bit (CmmLoad mem pk _) | not is32Bit = do code <- intLoadCode (MOV format) mem@@ -1382,7 +1391,7 @@ then return (OpImm (litToImm lit), nilOL) else getNonClobberedOperand_generic (CmmLit lit) -getNonClobberedOperand (CmmLoad mem pk) = do+getNonClobberedOperand (CmmLoad mem pk _) = do is32Bit <- is32BitPlatform -- this logic could be simplified -- TODO FIXME@@ -1406,7 +1415,7 @@ return (OpAddr src', mem_code `appOL` save_code) else -- if its a word or gcptr on 32bit?- getNonClobberedOperand_generic (CmmLoad mem pk)+ getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned) getNonClobberedOperand e = getNonClobberedOperand_generic e @@ -1441,7 +1450,7 @@ then return (OpImm (litToImm lit), nilOL) else getOperand_generic (CmmLit lit) -getOperand (CmmLoad mem pk) = do+getOperand (CmmLoad mem pk _) = do is32Bit <- is32BitPlatform use_sse2 <- sse2Enabled if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)@@ -1449,7 +1458,7 @@ Amode src mem_code <- getAmode mem return (OpAddr src, mem_code) else- getOperand_generic (CmmLoad mem pk)+ getOperand_generic (CmmLoad mem pk NaturallyAligned) getOperand e = getOperand_generic e @@ -1459,7 +1468,7 @@ return (OpReg reg, code) isOperand :: Bool -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _) = True+isOperand _ (CmmLoad _ _ _) = True isOperand is32Bit (CmmLit lit) = is32BitLit is32Bit lit || isSuitableFloatingPointLit lit isOperand _ _ = False@@ -1517,7 +1526,7 @@ isSuitableFloatingPointLit _ = False getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem pk) = do+getRegOrMem e@(CmmLoad mem pk _) = do is32Bit <- is32BitPlatform use_sse2 <- sse2Enabled if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)@@ -1604,7 +1613,7 @@ condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode -- memory vs immediate-condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)+condIntCode' is32Bit cond (CmmLoad x pk _) (CmmLit lit) | is32BitLit is32Bit lit = do Amode x_addr x_code <- getAmode x let@@ -1717,7 +1726,7 @@ -- specific case of adding/subtracting an integer to a particular address. -- ToDo: catch other cases where we can use an operation directly on a memory -- address.-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _, CmmLit (CmmInt i _)]) | addr == addr2, pk /= II64 || is32BitInteger i, Just instr <- check op@@ -1756,7 +1765,7 @@ -- Assign; dst is a reg, rhs is mem-assignReg_IntCode pk reg (CmmLoad src _) = do+assignReg_IntCode pk reg (CmmLoad src _ _) = do load_code <- intLoadCode (MOV pk) src platform <- ncgPlatform <$> getConfig return (load_code (getRegisterReg platform reg))@@ -1788,7 +1797,7 @@ genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock -genJump (CmmLoad mem _) regs = do+genJump (CmmLoad mem _ _) regs = do Amode target code <- getAmode mem return (code `snocOL` JMP (OpAddr target) regs)
compiler/GHC/CmmToC.hs view
@@ -218,14 +218,14 @@ CmmAssign dest src -> pprAssign platform dest src - CmmStore dest src+ CmmStore dest src align | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" else ptext (sLit ("ASSIGN_Word64"))) <> parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise- -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]+ -> hsep [ pprExpr platform (CmmLoad dest rep align), equals, pprExpr platform src <> semi ] where rep = cmmExprType platform src @@ -372,10 +372,10 @@ pprExpr :: Platform -> CmmExpr -> SDoc pprExpr platform e = case e of- CmmLit lit -> pprLit platform lit- CmmLoad e ty -> pprLoad platform e ty- CmmReg reg -> pprCastReg reg- CmmRegOff reg 0 -> pprCastReg reg+ CmmLit lit -> pprLit platform lit+ CmmLoad e ty align -> pprLoad platform e ty align+ CmmReg reg -> pprCastReg reg+ CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprCastReg reg <> char '+' <>@@ -386,13 +386,14 @@ CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" -pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc-pprLoad platform e ty+pprLoad :: Platform -> CmmExpr -> CmmType -> AlignmentSpec -> SDoc+pprLoad platform e ty _align | width == W64, wordWidth platform /= W64 = (if isFloatType ty then text "PK_DBL" else text "PK_Word64") <> parens (mkP_ <> pprExpr1 platform e) + -- TODO: exploit natural-alignment where possible | otherwise = case e of CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty)@@ -430,18 +431,97 @@ isMulMayOfloOp _ = False pprMachOpApp platform mop args- | Just ty <- machOpNeedsCast mop+ | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args) = ty <> parens (pprMachOpApp' platform mop args) | otherwise = pprMachOpApp' platform mop args --- Comparisons in C have type 'int', but we want type W_ (this is what--- resultRepOfMachOp says). The other C operations inherit their type--- from their operands, so no casting is required.-machOpNeedsCast :: MachOp -> Maybe SDoc-machOpNeedsCast mop+{-+Note [Zero-extending sub-word signed results]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a program like (from #20634):++ test() {+ bits64 ret;+ bits8 a,b;+ a = 0xe1 :: bits8; // == -31 signed+ b = %quot(a, 3::bits8); // == -10 signed+ ret = %zx64(a); // == 0xf6 unsigned+ return (ret);+ }++This program should return 0xf6 == 246. However, we need to be very careful+with when dealing with the result of the %quot. For instance, one might be+tempted produce code like:++ StgWord8 a = 0xe1U;+ StgInt8 b = (StgInt8) a / (StgInt8) 0x3U;+ StgWord ret = (W_) b;++However, this would be wrong; by widening `b` directly from `StgInt8` to+`StgWord` we will get sign-extension semantics: rather than 0xf6 we will get+0xfffffffffffffff6. To avoid this we must first cast `b` back to `StgWord8`,+ensuring that we get zero-extension semantics when we widen up to `StgWord`.++Note [When in doubt, cast arguments as unsigned]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general C's signed-ness behavior can lead to surprising results and+consequently we are very explicit about ensuring that arguments have the+correct signedness. For instance, consider a program like++ test() {+ bits64 ret, a, b;+ a = %neg(43 :: bits64);+ b = %neg(0x443c70fa3e465120 :: bits64);+ ret = %modu(a, b);+ return (ret);+ }++In this case both `a` and `b` will be StgInts in the generated C (since+`MO_Neg` is a signed operation). However, we want to ensure that we perform an+*unsigned* modulus operation, therefore we must be careful to cast both arguments+to StgWord. We do this for any operation where the signedness of the argument+may affect the operation's semantics.+-}++-- | The result type of most operations is determined by the operands. However,+-- there are a few exceptions: particularly operations which might get promoted+-- to a signed result. For these we explicitly cast the result.+machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc+machOpNeedsCast platform mop args+ -- Comparisons in C have type 'int', but we want type W_ (this is what+ -- resultRepOfMachOp says). | isComparisonMachOp mop = Just mkW_++ -- See Note [Zero-extended sub-word signed results]+ | signedOp mop+ , res_ty <- machOpResultType platform mop args+ , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv+ , let w = typeWidth res_ty+ , w < wordWidth platform+ = cast_it w++ -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word+ -- in C yet we want a Word8+ | Just w <- shiftOp mop = cast_it w++ -- The results of these operations may be promoted to signed values+ -- due to C11 section 6.3.1.1.+ | MO_Add w <- mop = cast_it w+ | MO_Sub w <- mop = cast_it w+ | MO_Mul w <- mop = cast_it w+ | MO_U_Quot w <- mop = cast_it w+ | MO_U_Rem w <- mop = cast_it w+ | MO_And w <- mop = cast_it w+ | MO_Or w <- mop = cast_it w+ | MO_Xor w <- mop = cast_it w+ | MO_Not w <- mop = cast_it w+ | otherwise = Nothing+ where+ cast_it w =+ let ty = machRep_U_CType platform w+ in Just $ parens ty pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc pprMachOpApp' platform mop args@@ -455,16 +535,32 @@ _ -> panic "PprC.pprMachOp : machop with wrong number of args" where+ pprArg e+ | needsFCasts mop = cCast platform (machRep_F_CType width) e -- Cast needed for signed integer ops- pprArg e | signedOp mop = cCast platform (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e- | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType platform e))) e- | otherwise = pprExpr1 platform e- needsFCasts (MO_F_Eq _) = False- needsFCasts (MO_F_Ne _) = False+ | signedOp mop = cCast platform (machRep_S_CType platform width) e+ -- See Note [When in doubt, cast arguments as unsigned]+ | needsUnsignedCast mop+ = cCast platform (machRep_U_CType platform width) e+ | otherwise = pprExpr1 platform e+ where+ width = typeWidth (cmmExprType platform e)+ needsFCasts (MO_F_Neg _) = True needsFCasts (MO_F_Quot _) = True needsFCasts mop = floatComparison mop + -- See Note [When in doubt, cast arguments as unsigned]+ needsUnsignedCast (MO_Mul _) = True+ needsUnsignedCast (MO_U_Shr _) = True+ needsUnsignedCast (MO_U_Quot _) = True+ needsUnsignedCast (MO_U_Rem _) = True+ needsUnsignedCast (MO_U_Ge _) = True+ needsUnsignedCast (MO_U_Le _) = True+ needsUnsignedCast (MO_U_Gt _) = True+ needsUnsignedCast (MO_U_Lt _) = True+ needsUnsignedCast _ = False+ -- -------------------------------------------------------------------------- -- Literals @@ -768,6 +864,12 @@ signedOp (MO_SF_Conv _ _) = True signedOp _ = False +shiftOp :: MachOp -> Maybe Width+shiftOp (MO_Shl w) = Just w+shiftOp (MO_U_Shr w) = Just w+shiftOp (MO_S_Shr w) = Just w+shiftOp _ = Nothing+ floatComparison :: MachOp -> Bool -- comparison between float args floatComparison (MO_F_Eq _) = True floatComparison (MO_F_Ne _) = True@@ -1157,7 +1259,7 @@ te_Stmt :: CmmNode e x -> TE () te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e-te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r+te_Stmt (CmmStore l r _) = te_Expr l >> te_Expr r te_Stmt (CmmUnsafeForeignCall target rs es) = do te_Target target mapM_ te_temp rs@@ -1173,7 +1275,7 @@ te_Expr :: CmmExpr -> TE () te_Expr (CmmLit lit) = te_Lit lit-te_Expr (CmmLoad e _) = te_Expr e+te_Expr (CmmLoad e _ _) = te_Expr e te_Expr (CmmReg r) = te_Reg r te_Expr (CmmMachOp _ es) = mapM_ te_Expr es te_Expr (CmmRegOff r _) = te_Reg r
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -127,7 +127,8 @@ CmmUnwind {} -> return (nilOL, []) CmmAssign reg src -> genAssign reg src- CmmStore addr src -> genStore addr src+ CmmStore addr src align+ -> genStore addr src align CmmBranch id -> genBranch id CmmCondBranch arg true false likely@@ -208,7 +209,7 @@ castV <- lift $ mkLocalVar ty ve <- exprToVarW e statement $ Assignment castV $ Cast LM_Uitofp ve width- statement $ Store castV dstV+ statement $ Store castV dstV Nothing genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++@@ -264,12 +265,12 @@ AMO_Or -> LAO_Or AMO_Xor -> LAO_Xor retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst- statement $ Store retVar dstVar+ statement $ Store retVar dstVar Nothing genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst)- v1 <- genLoadW True addr (localRegType dst)- statement $ Store v1 dstV+ v1 <- genLoadW True addr (localRegType dst) NaturallyAligned+ statement $ Store v1 dstV Nothing genCall (PrimTarget (MO_Cmpxchg _width)) [dst] [addr, old, new] = runStmtsDecls $ do@@ -283,7 +284,7 @@ retVar <- doExprW (LMStructU [targetTy,i1]) $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst retVar' <- doExprW targetTy $ ExtractV retVar 0- statement $ Store retVar' dstVar+ statement $ Store retVar' dstVar Nothing genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar@@ -293,7 +294,7 @@ ptrExpr = Cast LM_Inttoptr addrVar ptrTy ptrVar <- doExprW ptrTy ptrExpr resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)- statement $ Store resVar dstV+ statement $ Store resVar dstV Nothing genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do addrVar <- exprToVarW addr@@ -353,8 +354,8 @@ retH <- doExprW width $ Cast LM_Trunc retShifted width dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH)- statement $ Store retL dstRegL- statement $ Store retH dstRegH+ statement $ Store retL dstRegL Nothing+ statement $ Store retH dstRegH Nothing genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do let width = widthToLlvmInt w@@ -385,9 +386,9 @@ dstRegL <- getCmmRegW (CmmLocal dstL) dstRegH <- getCmmRegW (CmmLocal dstH) dstRegC <- getCmmRegW (CmmLocal dstC)- statement $ Store retL dstRegL- statement $ Store retH dstRegH- statement $ Store retC dstRegC+ statement $ Store retL dstRegL Nothing+ statement $ Store retH dstRegH Nothing+ statement $ Store retC dstRegC Nothing -- MO_U_QuotRem2 is another case we handle by widening the registers to double -- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The@@ -421,8 +422,8 @@ retRem <- narrow retExtRem dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) dstRegR <- lift $ getCmmReg (CmmLocal dstR)- statement $ Store retDiv dstRegQ- statement $ Store retRem dstRegR+ statement $ Store retDiv dstRegQ Nothing+ statement $ Store retRem dstRegR Nothing -- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from -- which we need to extract the actual values.@@ -529,7 +530,7 @@ vreg <- getCmmRegW (CmmLocal creg) if retTy == pLower (getVarType vreg) then do- statement $ Store v1 vreg+ statement $ Store v1 vreg Nothing doReturn else do let ty = pLower $ getVarType vreg@@ -541,7 +542,7 @@ ++ " returned type!" v2 <- doExprW ty $ Cast op v1 ty- statement $ Store v2 vreg+ statement $ Store v2 vreg Nothing doReturn -- | Generate a call to an LLVM intrinsic that performs arithmetic operation@@ -570,8 +571,8 @@ (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width dstRegV <- getCmmReg (CmmLocal dstV) dstRegO <- getCmmReg (CmmLocal dstO)- let storeV = Store value dstRegV- storeO = Store overflow dstRegO+ let storeV = Store value dstRegV Nothing+ storeO = Store overflow dstRegO Nothing return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) genCallWithOverflow _ _ _ _ = panic "genCallExtract: wrong ForeignTarget or number of arguments"@@ -636,7 +637,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast" retVs'- let s2 = Store retV' dstV+ let s2 = Store retV' dstV Nothing let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2@@ -668,7 +669,7 @@ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] let retV' = singletonPanic "genCallSimpleCast2" retVs'- let s2 = Store retV' dstV+ let s2 = Store retV' dstV Nothing let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2@@ -987,54 +988,54 @@ -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty- let s2 = Store v vreg+ let s2 = Store v vreg Nothing return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty- let s2 = Store v vreg+ let s2 = mkStore v vreg NaturallyAligned return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do- let s1 = Store vval vreg+ let s1 = Store vval vreg Nothing return (stmts `snocOL` s1, top2) -- | CmmStore operation-genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData+genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic-genStore addr@(CmmReg (CmmGlobal r)) val- = genStore_fast addr r 0 val+genStore addr@(CmmReg (CmmGlobal r)) val alignment+ = genStore_fast addr r 0 val alignment -genStore addr@(CmmRegOff (CmmGlobal r) n) val- = genStore_fast addr r n val+genStore addr@(CmmRegOff (CmmGlobal r) n) val alignment+ = genStore_fast addr r n val alignment genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- val- = genStore_fast addr r (fromInteger n) val+ val alignment+ = genStore_fast addr r (fromInteger n) val alignment genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- val- = genStore_fast addr r (negate $ fromInteger n) val+ val alignment+ = genStore_fast addr r (negate $ fromInteger n) val alignment -- generic case-genStore addr val- = getTBAAMeta topN >>= genStore_slow addr val+genStore addr val alignment+ = getTBAAMeta topN >>= genStore_slow addr val alignment -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8].-genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec -> LlvmM StmtData-genStore_fast addr r n val+genStore_fast addr r n val alignment = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r@@ -1047,7 +1048,7 @@ case pLower grt == getVarType vval of -- were fine True -> do- let s3 = MetaStmt meta $ Store vval ptr+ let s3 = MetaStmt meta $ mkStore vval ptr alignment return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) @@ -1055,19 +1056,19 @@ False -> do let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty- let s4 = MetaStmt meta $ Store vval ptr'+ let s4 = MetaStmt meta $ mkStore vval ptr' alignment return (stmts `appOL` 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 addr val meta+ False -> genStore_slow addr val alignment meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed.-genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData-genStore_slow addr val meta = do+genStore_slow :: CmmExpr -> CmmExpr -> AlignmentSpec -> [MetaAnnot] -> LlvmM StmtData+genStore_slow addr val alignment meta = do (vaddr, stmts1, top1) <- exprToVar addr (vval, stmts2, top2) <- exprToVar val @@ -1079,17 +1080,17 @@ -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty- let s2 = MetaStmt meta $ Store v vaddr+ let s2 = MetaStmt meta $ mkStore v vaddr alignment return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do- let s1 = MetaStmt meta $ Store vval vaddr+ let s1 = MetaStmt meta $ mkStore vval vaddr alignment return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord platform -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty- let s2 = MetaStmt meta $ Store vval vptr+ let s2 = MetaStmt meta $ mkStore vval vptr alignment return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other ->@@ -1099,6 +1100,16 @@ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ showSDoc dflags (ppVar opts vaddr))) +mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement+mkStore vval vptr alignment =+ Store vval vptr align+ where+ ty = pLower (getVarType vptr)+ align = case alignment of+ -- See Note [Alignment of vector-typed values]+ _ | isVector ty -> Just 1+ Unaligned -> Just 1+ NaturallyAligned -> Nothing -- | Unconditional branch genBranch :: BlockId -> LlvmM StmtData@@ -1249,8 +1260,8 @@ CmmLit lit -> genLit opt lit - CmmLoad e' ty- -> genLoad False e' ty+ CmmLoad e' ty align+ -> genLoad False e' ty align -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly.@@ -1684,40 +1695,40 @@ -- | Handle CmmLoad expression.-genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData+genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic-genLoad atomic e@(CmmReg (CmmGlobal r)) ty- = genLoad_fast atomic e r 0 ty+genLoad atomic e@(CmmReg (CmmGlobal r)) ty align+ = genLoad_fast atomic e r 0 ty align -genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty- = genLoad_fast atomic e r n ty+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty align+ = genLoad_fast atomic e r n ty align genLoad atomic e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- ty- = genLoad_fast atomic e r (fromInteger n) ty+ ty align+ = genLoad_fast atomic e r (fromInteger n) ty align genLoad atomic e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))])- ty- = genLoad_fast atomic e r (negate $ fromInteger n) ty+ ty align+ = genLoad_fast atomic e r (negate $ fromInteger n) ty align -- generic case-genLoad atomic e ty- = getTBAAMeta topN >>= genLoad_slow atomic e ty+genLoad atomic e ty align+ = getTBAAMeta topN >>= genLoad_slow atomic e ty align -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType- -> LlvmM ExprData-genLoad_fast atomic e r n ty = do+ -> AlignmentSpec -> LlvmM ExprData+genLoad_fast atomic e r n ty align = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) meta <- getTBAARegMeta r@@ -1730,7 +1741,7 @@ case grt == ty' of -- were fine True -> do- (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)+ (var, s3) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr align) return (var, s1 `snocOL` s2 `snocOL` s3, []) @@ -1738,21 +1749,19 @@ False -> do let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty- (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')+ (var, s4) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr' align) return (var, 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 atomic e ty meta- where- loadInstr ptr | atomic = ALoad SyncSeqCst False ptr- | otherwise = Load ptr+ False -> genLoad_slow atomic e ty align meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed.-genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData-genLoad_slow atomic e ty meta = do+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> [MetaAnnot]+ -> LlvmM ExprData+genLoad_slow atomic e ty align meta = do platform <- getPlatform dflags <- getDynFlags opts <- getLlvmOpts@@ -1760,23 +1769,43 @@ iptr <- exprToVarW e case getVarType iptr of LMPointer _ ->- doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)+ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic iptr align) i@(LMInt _) | i == llvmWord platform -> do let pty = LMPointer $ cmmToLlvmType ty ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty- doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)+ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) other -> pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr platform e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ showSDoc dflags (ppVar opts iptr)))- where- loadInstr ptr | atomic = ALoad SyncSeqCst False ptr- | otherwise = Load ptr +{-+Note [Alignment of vector-typed values]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86, vector types need to be 16-byte aligned for aligned+access, but we have no way of guaranteeing that this is true with GHC+(we would need to modify the layout of the stack and closures, change+the storage manager, etc.). So, we blindly tell LLVM that *any* vector+store or load could be unaligned. In the future we may be able to+guarantee that certain vector access patterns are aligned, in which+case we will need a more granular way of specifying alignment.+-} +mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression+mkLoad atomic vptr alignment+ | atomic = ALoad SyncSeqCst False vptr+ | otherwise = Load vptr align+ where+ ty = pLower (getVarType vptr)+ align = case alignment of+ -- See Note [Alignment of vector-typed values]+ _ | isVector ty -> Just 1+ Unaligned -> Just 1+ NaturallyAligned -> Nothing+ -- | Handle CmmReg expression. This will return a pointer to the stack -- location of the register. Throws an error if it isn't allocated on -- the stack.@@ -1814,7 +1843,7 @@ where loadFromStack = do ptr <- getCmmReg reg let ty = pLower $ getVarType ptr- (v, s) <- doExpr ty (Load ptr)+ (v, s) <- doExpr ty (Load ptr Nothing) return (v, ty, unitOL s) -- | Allocate a local CmmReg on the stack@@ -1941,7 +1970,7 @@ rval = if isLive r then arg else trash alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 markStackReg r- return $ toOL [alloc, Store rval reg]+ return $ toOL [alloc, Store rval reg Nothing] return (concatOL stmtss `snocOL` jumpToEntry, []) where@@ -2105,8 +2134,8 @@ getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar getCmmRegW = lift . getCmmReg -genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar-genLoadW atomic e ty = liftExprData $ genLoad atomic e ty+genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar+genLoadW atomic e ty alignment = liftExprData $ genLoad atomic e ty alignment -- | Return element of single-element list; 'panic' if list is not a single-element list singletonPanic :: String -> [a] -> a
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -60,6 +60,15 @@ { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries } +-- This is a strict alternative to (,)+-- See Note [Space Leaks in Demand Analysis]+data WithDmdType a = WithDmdType !DmdType !a++getAnnotated :: WithDmdType a -> a+getAnnotated (WithDmdType _ a) = a++data DmdResult a b = R !a !b+ -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. --@@ -67,19 +76,19 @@ -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds- = snd $ go (emptyAnalEnv opts fam_envs) binds+ = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?]- go _ [] = (nopDmdType, [])+ go _ [] = WithDmdType nopDmdType [] go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body where anal_body env'- | (body_ty, bs') <- go env' bs- = (add_exported_uses env' body_ty (bindersOf b), bs')+ | WithDmdType body_ty bs' <- go env' bs+ = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs' - cons_up :: (a, b, [b]) -> (a, [b])- cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs')+ cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]+ cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType add_exported_uses env = foldl' (add_exported_use env)@@ -229,9 +238,9 @@ -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind- -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.+ -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. -- where the binding is in scope- -> (DmdType, CoreBind, a)+ -> WithDmdType (DmdResult CoreBind a) dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id@@ -258,12 +267,17 @@ -- 'useLetUp'). -- -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)-dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')+dmdAnalBindLetUp :: TopLevelFlag+ -> AnalEnv+ -> Id+ -> CoreExpr+ -> (AnalEnv -> WithDmdType a)+ -> WithDmdType (DmdResult CoreBind a)+dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) where- (body_ty, body') = anal_body env- (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id- id' = setBindIdDemandInfo top_lvl id id_dmd+ WithDmdType body_ty body' = anal_body env+ WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id+ !id' = setBindIdDemandInfo top_lvl id id_dmd (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs -- See Note [Absence analysis for stable unfoldings and RULES]@@ -282,7 +296,7 @@ -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of NonRec id rhs | (env', lazy_fv, id1, rhs1) <-@@ -292,14 +306,15 @@ | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs -> do_rest env' lazy_fv pairs' Rec where- do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')+ do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') where- (body_ty, body') = anal_body env'+ WithDmdType body_ty body' = anal_body env' -- see Note [Lazy and unleashable free variables]- dmd_ty = addLazyFVs body_ty lazy_fv- (!final_ty, id_dmds) = findBndrsDmds env' dmd_ty (map fst pairs1)- pairs2 = zipWith do_one pairs1 id_dmds- do_one (id', rhs') dmd = (setBindIdDemandInfo top_lvl id' dmd, rhs')+ dmd_ty = addLazyFVs body_ty lazy_fv+ WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1)+ -- Important to force this as build_bind might not force it.+ !pairs2 = strictZipWith do_one pairs1 id_dmds+ do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand.@@ -328,7 +343,7 @@ -> CoreExpr -- Should obey the let/app invariant -> (PlusDmdArg, CoreExpr) dmdAnalStar env (n :* cd) e- | (dmd_ty, e') <- dmdAnal env cd e+ | WithDmdType dmd_ty e' <- dmdAnal env cd e = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) -- The argument 'e' should satisfy the let/app invariant -- See Note [Analysing with absent demand] in GHC.Types.Demand@@ -337,33 +352,33 @@ -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand*- -> CoreExpr -> (DmdType, CoreExpr)+ -> CoreExpr -> WithDmdType CoreExpr dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit)-dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact+dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit)+dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co)- = (unitDmdType (coercionDmdEnv co), Coercion co)+ = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co) dmdAnal' env dmd (Var var)- = (dmdTransform env var dmd, Var var)+ = WithDmdType (dmdTransform env var dmd) (Var var) dmdAnal' env dmd (Cast e co)- = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)+ = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co) where- (dmd_ty, e') = dmdAnal env dmd e+ WithDmdType dmd_ty e' = dmdAnal env dmd e dmdAnal' env dmd (Tick t e)- = (dmd_ty, Tick t e')+ = WithDmdType dmd_ty (Tick t e') where- (dmd_ty, e') = dmdAnal env dmd e+ WithDmdType dmd_ty e' = dmdAnal env dmd e dmdAnal' env dmd (App fun (Type ty))- = (fun_ty, App fun' (Type ty))+ = WithDmdType fun_ty (App fun' (Type ty)) where- (fun_ty, fun') = dmdAnal env dmd fun+ WithDmdType fun_ty fun' = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-)@@ -373,7 +388,7 @@ -- value arguments (#10288) let call_dmd = mkCalledOnceDmd dmd- (fun_ty, fun') = dmdAnal env call_dmd fun+ WithDmdType fun_ty fun' = dmdAnal env call_dmd fun (arg_dmd, res_ty) = splitDmdTy fun_ty (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg in@@ -385,41 +400,46 @@ -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])- (res_ty `plusDmdType` arg_ty, App fun' arg')+ WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') dmdAnal' env dmd (Lam var body) | isTyVar var = let- (body_ty, body') = dmdAnal env dmd body+ WithDmdType body_ty body' = dmdAnal env dmd body in- (body_ty, Lam var body')+ WithDmdType body_ty (Lam var body') | otherwise = let (n, body_dmd) = peelCallDmd dmd -- body_dmd: a demand to analyze the body - (body_ty, body') = dmdAnal env body_dmd body- (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var+ WithDmdType body_ty body' = dmdAnal env body_dmd body+ WithDmdType lam_ty var' = annotateLamIdBndr env notArgOfDfun body_ty var+ new_dmd_type = multDmdType n lam_ty in- (multDmdType n lam_ty, Lam var' body')+ WithDmdType new_dmd_type (Lam var' body') dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. | is_single_data_alt alt = let- (rhs_ty, rhs') = dmdAnal env dmd rhs- (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs- (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr+ WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs+ WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs+ WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! (_ :* case_bndr_sd) = case_bndr_dmd -- Compute demand on the scrutinee- (bndrs', scrut_sd)+ -- FORCE the result, otherwise thunks will end up retaining the+ -- whole DmdEnv+ !(!bndrs', !scrut_sd) | DataAlt _ <- alt , id_dmds <- addCaseBndrDmd case_bndr_sd dmds -- See Note [Demand on scrutinee of a product case]- = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds)+ = let !new_info = setBndrsDemandInfo bndrs id_dmds+ !new_prod = mkProd id_dmds+ in (new_info, new_prod) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once.@@ -432,9 +452,9 @@ | otherwise = alt_ty2 - (scrut_ty, scrut') = dmdAnal env scrut_sd scrut+ WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty- case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd+ !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd@@ -443,16 +463,27 @@ -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $- (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])+ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True +++ dmdAnal' env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives- (alt_tys, alts') = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts- (scrut_ty, scrut') = dmdAnal env topSubDmd scrut- (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr+ WithDmdType alt_ty alts' = combineAltDmds alts++ combineAltDmds [] = WithDmdType botDmdType []+ combineAltDmds (a:as) =+ let+ WithDmdType cur_ty a' = dmdAnalSumAlt env dmd case_bndr a+ WithDmdType rest_ty as' = combineAltDmds as+ in WithDmdType (lubDmdType cur_ty rest_ty) (a':as')++ WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut+ WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives@@ -460,9 +491,9 @@ alt_ty2 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException fam_envs scrut- = deferAfterPreciseException alt_ty+ = deferAfterPreciseException alt_ty1 | otherwise- = alt_ty+ = alt_ty1 res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty in@@ -471,13 +502,13 @@ -- , text "alt_tys" <+> ppr alt_tys -- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $- (res_ty, Case scrut' case_bndr' ty alts')+ WithDmdType res_ty (Case scrut' case_bndr' ty alts') dmdAnal' env dmd (Let bind body)- = (final_ty, Let bind' body')+ = WithDmdType final_ty (Let bind' body') where- (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'- go' env' = dmdAnal env' dmd body+ !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go'+ go' !env' = dmdAnal env' dmd body -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'.@@ -514,14 +545,16 @@ | otherwise = False -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)- | (rhs_ty, rhs') <- dmdAnal env dmd rhs- , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs+ | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs+ , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] id_dmds = addCaseBndrDmd case_bndr_sd dmds- = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs')+ -- Do not put a thunk into the Alt+ !new_ids = setBndrsDemandInfo bndrs id_dmds+ = WithDmdType alt_ty (Alt con new_ids rhs') {- Note [Analysing with absent demand]@@ -769,13 +802,13 @@ | otherwise = mkCalledOnceDmds rhs_arity topSubDmd - (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs+ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) id' = id `setIdStrictness` sig- env' = extendAnalEnv top_lvl env id' sig+ !env' = extendAnalEnv top_lvl env id' sig -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason@@ -796,7 +829,7 @@ rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id -- See Note [Lazy and unleashable free variables]- (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2+ !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs@@ -1099,9 +1132,9 @@ start_env | first_round = env | otherwise = nonVirgin env - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)+ start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs+ !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed@@ -1110,8 +1143,8 @@ = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $ ((env', lazy_fv'), (id', rhs')) where- (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs- lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1+ !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+ !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]@@ -1235,35 +1268,40 @@ setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds | isTyVar b = b : setBndrsDemandInfo bs ds-setBndrsDemandInfo (b:bs) (d:ds) = setIdDemandInfo b d : setBndrsDemandInfo bs ds+setBndrsDemandInfo (b:bs) (d:ds) =+ let !new_info = setIdDemandInfo b d+ !vars = setBndrsDemandInfo bs ds+ in new_info : vars setBndrsDemandInfo [] ds = ASSERT( null ds ) [] setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) -annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)+annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var -- The returned env has the var deleted -- The returned var is annotated with demand info -- according to the result demand of the provided demand type -- No effect on the argument demands annotateBndr env dmd_ty var- | isId var = (dmd_ty', setIdDemandInfo var dmd)- | otherwise = (dmd_ty, var)+ | isId var = WithDmdType dmd_ty' new_id+ | otherwise = WithDmdType dmd_ty var where- (dmd_ty', dmd) = findBndrDmd env False dmd_ty var+ new_id = setIdDemandInfo var dmd+ WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var annotateLamIdBndr :: AnalEnv -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body -> Id -- Lambda binder- -> (DmdType, -- Demand type of lambda- Id) -- and binder annotated with demand+ -> WithDmdType Id -- Demand type of lambda+ -- and binder annotated with demand annotateLamIdBndr env arg_of_dfun dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $- (final_ty, setIdDemandInfo id dmd)+ WithDmdType final_ty new_id where+ new_id = setIdDemandInfo id dmd -- Watch out! See note [Lambda-bound unfoldings] final_ty = case maybeUnfoldingTemplate (idUnfolding id) of Nothing -> main_ty@@ -1272,7 +1310,7 @@ (unf_ty, _) = dmdAnalStar env dmd unf main_ty = addDemand dmd dmd_ty'- (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id+ WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1421,23 +1459,23 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])+findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where- go dmd_ty [] = (dmd_ty, [])+ go dmd_ty [] = WithDmdType dmd_ty [] go dmd_ty (b:bs)- | isId b = let (dmd_ty1, dmds) = go dmd_ty bs- (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b- in (dmd_ty2, dmd : dmds)+ | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs+ WithDmdType dmd_ty2 dmd = findBndrDmd env False dmd_ty1 b+ in WithDmdType dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)+findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $- (dmd_ty', dmd')+ WithDmdType dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty)@@ -1525,4 +1563,36 @@ duplicating actual function calls. Also see #11731.++Note [Space Leaks in Demand Analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket: #15455+MR: !5399++In the past the result of demand analysis was not forced until the whole module+had finished being analysed. In big programs, this led to a big build up of thunks+which were all ultimately forced at the end of the analysis.++This was because the return type of the analysis was a lazy pair:+ dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr)+To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but+we were never sure we had added enough.+The easiest way to systematically fix this was to use a strict pair type for the+return value of the analysis so that we can be more confident that the result+is incrementally computed rather than all at the end.++A second, only loosely related point is that+the updating of Ids was not forced because the result of updating+an Id was placed into a lazy field in CoreExpr. This meant that until the end of+demand analysis, the unforced Ids would retain the DmdEnv which the demand information+was fetch from. Now we are quite careful to force Ids before putting them+back into core expressions so that we can garbage-collect the environments more eagerly.+For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced+or `dmdAnalSumAlt`.++The net result of all these improvements is the peak live memory usage of compiling+jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also+decrease because we allocate a lot fewer thunks which we immediately overwrite and+also runtime for the pass is faster! Overall, good wins.+ -}
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -162,16 +162,17 @@ maybe_strictness_before _ = CoreDoNothing - base_mode = SimplMode { sm_phase = panic "base_mode"- , sm_names = []- , sm_dflags = dflags- , sm_logger = logger- , sm_uf_opts = unfoldingOpts dflags- , sm_rules = rules_on- , sm_eta_expand = eta_expand_on- , sm_inline = True- , sm_case_case = True- , sm_pre_inline = pre_inline_on+ base_mode = SimplMode { sm_phase = panic "base_mode"+ , sm_names = []+ , sm_dflags = dflags+ , sm_logger = logger+ , sm_uf_opts = unfoldingOpts dflags+ , sm_rules = rules_on+ , sm_eta_expand = eta_expand_on+ , sm_cast_swizzle = True+ , sm_inline = True+ , sm_case_case = True+ , sm_pre_inline = pre_inline_on } simpl_phase phase name iter
compiler/GHC/Core/Opt/Simplify.hs view
@@ -362,16 +362,17 @@ -- ANF-ise a constructor or PAP rhs -- We get at most one float per argument here+ ; let body_env1 = body_env `setInScopeFromF` body_floats1+ -- body_env1: add to in-scope set the binders from body_floats1+ -- so that prepareBinding knows what is in scope in body1 ; (let_floats, bndr2, body2) <- {-#SCC "prepareBinding" #-}- prepareBinding env top_lvl bndr bndr1 body1+ prepareBinding body_env1 top_lvl bndr bndr1 body1 ; let body_floats2 = body_floats1 `addLetFloats` let_floats - ; (rhs_floats, rhs')+ ; (rhs_floats, body3) <- if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2) then -- No floating, revert to body1- {-#SCC "simplLazyBind-no-floating" #-}- do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont- ; return (emptyFloats env, rhs') }+ return (emptyFloats env, wrapFloats body_floats2 body1) else if null tvs then -- Simple floating {-#SCC "simplLazyBind-simple-floating" #-}@@ -384,11 +385,11 @@ ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl tvs' body_floats2 body2 ; let floats = foldl' extendFloats (emptyFloats env) poly_binds- ; rhs' <- mkLam env tvs' body3 rhs_cont- ; return (floats, rhs') }+ ; return (floats, body3) } - ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)- top_lvl Nothing bndr bndr2 rhs'+ ; let env' = env `setInScopeFromF` rhs_floats+ ; rhs' <- mkLam env' tvs' body3 rhs_cont+ ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr2 rhs' ; return (rhs_floats `addFloats` bind_float, env2) } --------------------------@@ -627,7 +628,7 @@ -- Transforms a RHS into a better RHS by ANF'ing args -- for expandable RHSs: constructors and PAPs -- e.g x = Just e--- becomes a = e+-- becomes a = e -- 'a' is fresh -- x = Just a -- See Note [prepareRhs] prepareRhs mode top_lvl occ rhs0@@ -720,6 +721,10 @@ -- Now something very like completeBind, -- but without the postInlineUnconditionally part ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1+ -- Technically we should extend the in-scope set in 'env' with+ -- the 'floats' from prepareRHS; but they are all fresh, so there is+ -- no danger of introducing name shadowig in eta expansion+ ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2 ; let final_id = addLetBndrInfo var arity_type unf@@ -1000,7 +1005,7 @@ ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $ -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $ -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $- return (wrapFloats floats expr') }+ return $! wrapFloats floats expr' } -------------------------------------------------- simplExprF :: SimplEnv@@ -1496,8 +1501,11 @@ | isSimplified dup_flag = return (dup_flag, arg_env, arg) | otherwise- = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg- ; return (Simplified, zapSubstEnv arg_env, arg') }+ = do { let arg_env' = arg_env `setInScopeFromE` env+ ; arg' <- simplExpr arg_env' arg+ ; return (Simplified, zapSubstEnv arg_env', arg') }+ -- Return a StaticEnv that includes the in-scope set from 'env',+ -- because arg' may well mention those variables (#20639) {- ************************************************************************@@ -2236,7 +2244,8 @@ ; return Nothing } where- ropts = initRuleOpts dflags+ -- Force this to avoid retaining DynFlags and hence SimplEnv+ !ropts = initRuleOpts dflags dflags = seDynFlags env logger = seLogger env zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]@@ -2975,7 +2984,7 @@ -> InAlt -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)+simplAlt env _ !imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs) = ASSERT( null bndrs ) do { let env' = addBinderUnfolding env case_bndr' (mkOtherCon imposs_deflt_cons)@@ -3000,7 +3009,9 @@ con_app = mkConApp2 con inst_tys' vs' ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app- ; rhs' <- simplExprC env'' rhs cont'+ -- Forced so that simplExprC forces wrapFloats which means we don't+ -- retain the InScopeSet in SimplFloats+ ; !rhs' <- simplExprC env'' rhs cont' ; return (Alt (DataAlt con) vs' rhs') } {- Note [Adding evaluatedness info to pattern-bound variables]@@ -3088,7 +3099,9 @@ ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } where- mk_simple_unf = mkSimpleUnfolding (seUnfoldingOpts env)+ -- Force the opts, so that the whole SimplEnv isn't retained+ !opts = seUnfoldingOpts env+ mk_simple_unf = mkSimpleUnfolding opts addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf@@ -3926,14 +3939,15 @@ | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify | otherwise- = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs+ = -- Otherwise, we end up retaining all the SimpleEnv+ let !opts = seUnfoldingOpts env+ in mkLetUnfolding opts top_lvl InlineRhs id new_rhs ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding uf_opts top_lvl src id new_rhs- = is_bottoming `seq` -- See Note [Force bottoming field]- return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)+mkLetUnfolding !uf_opts top_lvl src id new_rhs+ = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In GHC.Iface.Tidy we currently assume that, if we want to@@ -3941,8 +3955,11 @@ -- to expose. (We could instead use the RHS, but currently -- we don't.) The simple thing is always to have one. where- is_top_lvl = isTopLevel top_lvl- is_bottoming = isDeadEndId id+ -- Might as well force this, profiles indicate up to 0.5MB of thunks+ -- just from this site.+ !is_top_lvl = isTopLevel top_lvl+ -- See Note [Force bottoming field]+ !is_bottoming = isDeadEndId id ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag@@ -3979,11 +3996,17 @@ , ug_boring_ok = boring_ok } -- Happens for INLINE things- -> let guide' =+ -- Really important to force new_boring_ok as otherwise+ -- `ug_boring_ok` is a thunk chain of+ -- inlineBoringExprOk expr0+ -- || inlineBoringExprOk expr1 || ...+ -- See #20134+ -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+ guide' = UnfWhen { ug_arity = arity , ug_unsat_ok = sat_ok- , ug_boring_ok =- boring_ok || inlineBoringOk expr'+ , ug_boring_ok = new_boring_ok+ } -- Refresh the boring-ok flag, in case expr' -- has got small. This happens, notably in the inlinings@@ -4004,7 +4027,9 @@ | otherwise -> return noUnfolding -- Discard unstable unfoldings where uf_opts = seUnfoldingOpts env- is_top_lvl = isTopLevel top_lvl+ -- Forcing this can save about 0.5MB of max residency and the result+ -- is small and easy to compute so might as well force it.+ !is_top_lvl = isTopLevel top_lvl act = idInlineActivation id unf_env = updMode (updModeForStableUnfoldings act) env -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils@@ -4037,9 +4062,14 @@ eta-expand the stable unfolding to arity N too. Simple and consistent. Wrinkles++* See Note [Eta-expansion in stable unfoldings] in+ GHC.Core.Opt.Simplify.Utils+ * Don't eta-expand a trivial expr, else each pass will eta-reduce it, and then eta-expand again. See Note [Do not eta-expand trivial expressions] in GHC.Core.Opt.Simplify.Utils.+ * Don't eta-expand join points; see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point case (mb_cont = Just _) doesn't use eta_expand.@@ -4146,3 +4176,4 @@ than necesary. Allowing some inlining might, for example, eliminate a binding. -}+
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -873,6 +873,7 @@ -- unboxed tuple stuff that confuses the bytecode -- interpreter , sm_eta_expand = eta_expand_on+ , sm_cast_swizzle = True , sm_case_case = True , sm_pre_inline = pre_inline_on }@@ -883,14 +884,14 @@ uf_opts = unfoldingOpts dflags updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode--- See Note [Simplifying inside stable unfoldings] updModeForStableUnfoldings unf_act current_mode = current_mode { sm_phase = phaseFromActivation unf_act- , sm_inline = True- , sm_eta_expand = False }- -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]- -- sm_rules: just inherit; sm_rules might be "off"- -- because of -fno-enable-rewrite-rules+ , sm_eta_expand = False+ , sm_inline = True }+ -- sm_phase: see Note [Simplifying inside stable unfoldings]+ -- sm_eta_expand: see Note [Eta-expansion in stable unfoldings]+ -- sm_rules: just inherit; sm_rules might be "off"+ -- because of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter _ n) = Phase n phaseFromActivation _ = InitialPhase@@ -898,10 +899,13 @@ updModeForRules :: SimplMode -> SimplMode -- See Note [Simplifying rules] updModeForRules current_mode- = current_mode { sm_phase = InitialPhase- , sm_inline = False -- See Note [Do not expose strictness if sm_inline=False]- , sm_rules = False- , sm_eta_expand = False }+ = current_mode { sm_phase = InitialPhase+ , sm_inline = False+ -- See Note [Do not expose strictness if sm_inline=False]+ , sm_rules = False+ , sm_cast_swizzle = False+ -- See Note [Cast swizzling on rule LHSs]+ , sm_eta_expand = False } {- Note [Simplifying rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -931,24 +935,39 @@ ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for details. -Note [No eta expansion in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have a stable unfolding+Note [Cast swizzling on rule LHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the LHS of a RULE we may have+ (\x. blah |> CoVar cv)+where `cv` is a coercion variable. Critically, we really only want+coercion /variables/, not general coercions, on the LHS of a RULE. So+we don't want to swizzle this to+ (\x. blah) |> (Refl xty `FunCo` CoVar cv)+So we switch off cast swizzling in updModeForRules. +Note [Eta-expansion in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do eta-expansion inside stable unfoldings. It's extra work,+and can be expensive (the bizarre T18223 is a case in point).++See Note [Occurrence analysis for lambda binders] in GHC.Core.Opt.OccurAnal.++Historical note. There was /previously/ another reason not to do eta+expansion in stable unfoldings. If we have a stable unfolding+ f :: Ord a => a -> IO () -- Unfolding template -- = /\a \(d:Ord a) (x:a). bla -we do not want to eta-expand to+we previously did not want to eta-expand to f :: Ord a => a -> IO () -- Unfolding template -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co -because not specialisation of the overloading doesn't work properly-(see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509.+because not specialisation of the overloading didn't work properly (#9509).+But now it does: see Note [Account for casts in binding] in GHC.Core.Opt.Specialise -So we disable eta-expansion in stable unfoldings. Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1558,16 +1577,9 @@ = do { dflags <- getDynFlags ; mkLam' dflags bndrs body } where- mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr- mkLam' dflags bndrs (Cast body co)- | not (any bad bndrs)- -- Note [Casts and lambdas]- = do { lam <- mkLam' dflags bndrs body- ; return (mkCast lam (mkPiCos Representational bndrs co)) }- where- co_vars = tyCoVarsOfCo co- bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars+ mode = getMode env + mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr mkLam' dflags bndrs body@(Lam {}) = mkLam' dflags (bndrs ++ bndrs1) body1 where@@ -1577,19 +1589,31 @@ | tickishFloatable t = mkTick t <$> mkLam' dflags bndrs expr + mkLam' dflags bndrs (Cast body co)+ | -- Note [Casts and lambdas]+ sm_cast_swizzle mode+ , not (any bad bndrs)+ = do { lam <- mkLam' dflags bndrs body+ ; return (mkCast lam (mkPiCos Representational bndrs co)) }+ where+ co_vars = tyCoVarsOfCo co+ bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars+ mkLam' dflags bndrs body | gopt Opt_DoEtaReduction dflags- , Just etad_lam <- tryEtaReduce bndrs body+ , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body = do { tick (EtaReduction (head bndrs)) ; return etad_lam } | not (contIsRhs cont) -- See Note [Eta-expanding lambdas]- , sm_eta_expand (getMode env)+ , sm_eta_expand mode , any isRuntimeVar bndrs- , let body_arity = exprEtaExpandArity dflags body+ , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body , expandableArityType body_arity = do { tick (EtaExpansion (head bndrs))- ; let res = mkLams bndrs (etaExpandAT body_arity body)+ ; let res = {-# SCC "eta3" #-}+ mkLams bndrs $+ etaExpandAT body_arity body ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body) , text "after" <+> ppr res]) ; return res }@@ -1617,7 +1641,7 @@ guard. NB: We check the SimplEnv (sm_eta_expand), not DynFlags.- See Note [No eta expansion in stable unfoldings]+ See Note [Eta-expansion in stable unfoldings] Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1637,19 +1661,25 @@ /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co) (if not (g `in` co)) -Notice that it works regardless of 'e'. Originally it worked only-if 'e' was itself a lambda, but in some cases that resulted in-fruitless iteration in the simplifier. A good example was when-compiling Text.ParserCombinators.ReadPrec, where we had a definition-like (\x. Get `cast` g)-where Get is a constructor with nonzero arity. Then mkLam eta-expanded-the Get, and the next iteration eta-reduced it, and then eta-expanded-it again.+We call this "cast swizzling". It is controlled by sm_cast_swizzle.+See also Note [Cast swizzling on rule LHSs] -Note also the side condition for the case of coercion binders.-It does not make sense to transform- /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)-because the latter is not well-kinded.+Wrinkles++* Notice that it works regardless of 'e'. Originally it worked only+ if 'e' was itself a lambda, but in some cases that resulted in+ fruitless iteration in the simplifier. A good example was when+ compiling Text.ParserCombinators.ReadPrec, where we had a definition+ like (\x. Get `cast` g)+ where Get is a constructor with nonzero arity. Then mkLam eta-expanded+ the Get, and the next iteration eta-reduced it, and then eta-expanded+ it again.++* Note also the side condition for the case of coercion binders, namely+ not (any bad bndrs). It does not make sense to transform+ /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)+ because the latter is not well-kinded.+ ************************************************************************ * *
compiler/GHC/Core/Opt/Specialise.hs view
@@ -800,6 +800,7 @@ tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM () -- See Note [Warning about missed specialisations] tryWarnMissingSpecs dflags callers fn calls_for_fn+ | isClassOpId fn = return () -- See Note [Missed specialization for ClassOps] | wopt Opt_WarnMissedSpecs dflags && not (null callers) && allCallersInlined = doWarn $ Reason Opt_WarnMissedSpecs@@ -815,8 +816,41 @@ , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) +{- Note [Missed specialisation for ClassOps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19592 I saw a number of missed specialisation warnings+which were the result of things like: + case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ... +where isJumpishInstr is part of the Instruction class and defined like+this:++ class Instruction instr where+ ...+ isJumpishInstr :: instr -> Bool+ ...++isJumpishInstr is a ClassOp which will select the right method+from within the dictionary via our built in rules. See also+Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance.++We don't give these unfoldings, and as a result the specialiser+complains. But usually this doesn't matter. The simplifier will+apply the rule and we end up with++ case isJumpishInstrImplX86 eta3_a78C of { ...++Since isJumpishInstrImplX86 is defined for a concrete instance (given+by the dictionary) it is usually already well specialised!+Theoretically the implementation of a method could still be overloaded+over a different type class than what it's a method of. But I wasn't able+to make this go wrong, and SPJ thinks this should be fine as well.++So I decided to remove the warnings for failed specialisations on ClassOps+alltogether as they do more harm than good.+-}+ {- Note [Do not specialise imported DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket #18223 shows that specialising calls of DFuns is can cause a huge@@ -1987,6 +2021,8 @@ Reason: when specialising the body for a call (f ty dexp), we want to substitute dexp for d, and pick up specialised calls in the body of f.++We do allow casts, however; see Note [Account for casts in binding]. This doesn't always work. One example I came across was this: newtype Gen a = MkGen{ unGen :: Int -> a }
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -386,9 +386,21 @@ in case z of A -> j 1 2 B -> j 2 3 -Note that we still want to give @j@ the CPR property, so that @f@ has it. So+Note that we still want to give `j` the CPR property, so that `f` has it. So CPR *analyse* join points as regular functions, but don't *transform* them. +We could retain the CPR /signature/ on the worker after W/W, but it would+become outright wrong if the Simplifier pushes a non-trivial continuation+into it. For example:+ case (let $j x = (x,x) in ...) of alts+ ==>+ let $j x = case (x,x) of alts in case ... of alts+Before pushing the case in, `$j` has the CPR property, but not afterwards.++So we simply zap the CPR signature for join pints as part of the W/W pass.+The signature served its purpose during CPR analysis in propagating the+CPR property of `$j`.+ Doing W/W for returned products on a join point would be tricky anyway, as the worker could not be a join point because it would not be tail-called. However, doing the *argument* part of W/W still works for join points, since the wrapper@@ -510,7 +522,7 @@ where uf_opts = unfoldingOpts dflags- fn_info = idInfo fn_id+ fn_info = idInfo new_fn_id (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) cpr_ty = getCprSig (cprInfo fn_info)@@ -520,10 +532,17 @@ , ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty) <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) ct_cpr cpr_ty - new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)+ new_fn_id = zap_join_cpr $ zap_usage fn_id++ zap_usage = zapIdUsedOnceInfo . zapIdUsageEnvInfo -- See Note [Zapping DmdEnv after Demand Analyzer] and -- See Note [Zapping Used Once info WorkWrap] + zap_join_cpr id+ | isJoinId id = id `setIdCprInfo` topCprSig+ | otherwise = id+ -- See Note [Don't w/w join points for CPR]+ is_fun = notNull wrap_dmds || isJoinId fn_id -- See Note [Don't eta expand in w/w] is_eta_exp = length wrap_dmds == manifestArity rhs@@ -624,7 +643,7 @@ | otherwise -> do { work_uniq <- getUniqueM ; return (mkWWBindPair dflags fn_id fn_info arity rhs- work_uniq div cpr stuff) } }+ work_uniq div stuff) } } where rhs_fvs = exprFreeVars rhs arity = arityInfo fn_info@@ -638,10 +657,10 @@ mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity- -> CoreExpr -> Unique -> Divergence -> Cpr+ -> CoreExpr -> Unique -> Divergence -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)]-mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr+mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div (work_demands, join_arity, wrap_fn, work_fn) = [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it@@ -683,7 +702,7 @@ -- Even though we may not be at top level, -- it's ok to give it an empty DmdEnv - `setIdCprInfo` mkCprSig work_arity work_cpr_info+ `setIdCprInfo` topCprSig `setIdDemandInfo` worker_demand @@ -712,13 +731,6 @@ fn_inl_prag = inlinePragInfo fn_info fn_inline_spec = inl_inline fn_inl_prag fn_unfolding = unfoldingInfo fn_info-- -- Even if we don't w/w join points for CPR, we might still do so for- -- strictness. In which case a join point worker keeps its original CPR- -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker- -- doesn't have the CPR property anymore.- work_cpr_info | isJoinId fn_id = cpr- | otherwise = topCpr mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -609,7 +609,7 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd = case splitArgType_maybe fam_envs ty of Just dcpc@DataConPatContext{ dcpc_dc = dc }- | isStrUsedDmd dmd+ | isStrUsedDmd dmd || isUnliftedType ty , let arity = dataConRepArity dc -- See Note [Unpacking arguments with product and polymorphic demands] , Just cs <- split_prod_dmd_arity dmd arity
compiler/GHC/Core/Rules.hs view
@@ -40,11 +40,11 @@ , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks , stripTicksTopT, stripTicksTopE- , isJoinBind )+ , isJoinBind, mkCastMCo ) import GHC.Core.Ppr ( pprRules ) import GHC.Core.Type as Type ( Type, TCvSubst, extendTvSubst, extendCvSubst- , mkEmptyTCvSubst, substTy )+ , mkEmptyTCvSubst, getTyVar_maybe, substTy ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) import GHC.Core.Coercion as Coercion@@ -384,13 +384,13 @@ -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) --- See Note [Extra args in rule matching]+-- See Note [Extra args in the target] -- See comments on matchRule-lookupRule opts in_scope is_active fn args rules+lookupRule opts rule_env@(in_scope,_) is_active fn args rules = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ case go [] rules of [] -> Nothing- (m:ms) -> Just (findBest (fn,args') m ms)+ (m:ms) -> Just (findBest in_scope (fn,args') m ms) where rough_args = map roughTopName args @@ -403,7 +403,7 @@ go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] go ms [] = ms go ms (r:rs)- | Just e <- matchRule opts in_scope is_active fn args' rough_args r+ | Just e <- matchRule opts rule_env is_active fn args' rough_args r = go ((r,mkTicks ticks e):ms) rs | otherwise = -- pprTrace "match failed" (ppr r $$ ppr args $$@@ -413,16 +413,16 @@ -- , isCheapUnfolding unf] ) go ms rs -findBest :: (Id, [CoreExpr])+findBest :: InScopeSet -> (Id, [CoreExpr]) -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) -- All these pairs matched the expression -- Return the pair the most specific rule -- The (fn,args) is just for overlap reporting -findBest _ (rule,ans) [] = (rule,ans)-findBest target (rule1,ans1) ((rule2,ans2):prs)- | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs- | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs+findBest _ _ (rule,ans) [] = (rule,ans)+findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)+ | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs+ | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs | debugIsOn = let pp_rule rule = ifPprDebug (ppr rule) (doubleQuotes (ftext (ruleName rule)))@@ -432,12 +432,12 @@ <+> sep (map ppr args) , text "Rule 1:" <+> pp_rule rule1 , text "Rule 2:" <+> pp_rule rule2]) $- findBest target (rule1,ans1) prs- | otherwise = findBest target (rule1,ans1) prs+ findBest in_scope target (rule1,ans1) prs+ | otherwise = findBest in_scope target (rule1,ans1) prs where (fn,args) = target -isMoreSpecific :: CoreRule -> CoreRule -> Bool+isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool -- This tests if one rule is more specific than another -- We take the view that a BuiltinRule is less specific than -- anything else, because we want user-define rules to "win"@@ -448,37 +448,45 @@ -- {-# RULES "truncate/Double->Int" truncate = double2Int #-} -- double2Int :: Double -> Int -- We want the specific RULE to beat the built-in class-op rule-isMoreSpecific (BuiltinRule {}) _ = False-isMoreSpecific (Rule {}) (BuiltinRule {}) = True-isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })- (Rule { ru_bndrs = bndrs2, ru_args = args2- , ru_name = rule_name2, ru_rhs = rhs })- = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs)+isMoreSpecific _ (BuiltinRule {}) _ = False+isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True+isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })+ (Rule { ru_bndrs = bndrs2, ru_args = args2+ , ru_name = rule_name2, ru_rhs = rhs2 })+ = isJust (matchN (full_in_scope, id_unfolding_fun)+ rule_name2 bndrs2 args2 args1 rhs2) where id_unfolding_fun _ = NoUnfolding -- Don't expand in templates- in_scope = mkInScopeSet (mkVarSet bndrs1)- -- Actually we should probably include the free vars- -- of rule1's args, but I can't be bothered+ full_in_scope = in_scope `extendInScopeSetList` bndrs1 noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{--Note [Extra args in rule matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Extra args in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)),-but the rule firing has only consumed as many of the input args-as the ruleArity says. It's up to the caller to keep track-of any left-over args. E.g. if you call- lookupRule ... f [e1, e2, e3]-and it returns Just (r, rhs), where r has ruleArity 2-then the real rewrite is+/but/ the rule firing has only consumed as many of the input args+as the ruleArity says. The unused arguments are handled by the code in+GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule.++E.g. Rule "foo": forall a b. f p1 p2 = rhs+ Target: f e1 e2 e3++Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo"+has ruleArity 2. The real rewrite is f e1 e2 e3 ==> rhs e3 You might think it'd be cleaner for lookupRule to deal with the leftover arguments, by applying 'rhs' to them, but the main call in the Simplifier works better as it is. Reason: the 'args' passed to lookupRule are the result of a lazy substitution++Historical note:++At one stage I tried to match even if there are more args in the+/template/ than the target. I now think this is probably a bad idea.+Should the template (map f xs) match (map g)? I think not. For a+start, in general eta expansion wastes work. SLPJ July 99 -} ------------------------------------@@ -515,12 +523,12 @@ Nothing -> Nothing Just expr -> Just expr -matchRule _ in_scope is_active _ args rough_args+matchRule _ rule_env is_active _ args rough_args (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) | not (is_active act) = Nothing | ruleCantMatch tpl_tops rough_args = Nothing- | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs+ | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs -- | Initialize RuleOpts from DynFlags@@ -542,10 +550,16 @@ -> Maybe CoreExpr -- For a given match template and context, find bindings to wrap around -- the entire result and what should be substituted for each template variable.--- Fail if there are two few actual arguments from the target to match the template+--+-- Fail if there are too few actual arguments from the target to match the template+--+-- See Note [Extra args in the target]+-- If there are too /many/ actual arguments, we simply ignore the+-- trailing ones, returning the result of applying the rule to a prefix+-- of the actual arguments. matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs- = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es+ = do { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst) (mkEmptyTCvSubst in_scope) $ tmpl_vars `zip` tmpl_vars1@@ -562,11 +576,6 @@ , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) , rv_unf = id_unf } - go _ subst [] _ = Just subst- go _ _ _ [] = Nothing -- Fail if too few actual args- go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e- ; go menv subst1 ts es }- lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr) -- Need to return a RuleSubst solely for the benefit of mk_fake_ty lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })@@ -678,12 +687,6 @@ * * ********************************************************************* -} --- * The domain of the TvSubstEnv and IdSubstEnv are the template--- variables passed into the match.------ * The BindWrapper in a RuleSubst are the bindings floated out--- from nested matches; see the Let case of match, below--- data RuleMatchEnv = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* -- (lambda/case)@@ -692,16 +695,45 @@ , rv_fltR :: Subst -- Renamings for floated let-bindings -- (domain disjoint from envR of rv_lcl) -- See Note [Matching lets]+ -- N.B. The InScopeSet of rv_fltR is always ignored;+ -- see (4) in Note [Matching lets]. , rv_unf :: IdUnfoldingFun } +{- Note [rv_lcl in RuleMatchEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider matching+ Template: \x->f+ Target: \f->f++where 'f' is free in the template. When we meet the lambdas we must+remember to rename f :-> f' in the target, as well as x :-> f+in the template. The rv_lcl::RnEnv2 does that.++Similarly, consider matching+ Template: {a} \b->b+ Target: \a->3+We must rename the \a. Otherwise when we meet the lambdas we might+substitute [b :-> a] in the template, and then erroneously succeed in+matching what looks like the template variable 'a' against 3.++So we must add the template vars to the in-scope set before starting;+see `init_menv` in `matchN`.+-}+ rvInScopeEnv :: RuleMatchEnv -> InScopeEnv rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) +-- * The domain of the TvSubstEnv and IdSubstEnv are the template+-- variables passed into the match.+--+-- * The BindWrapper in a RuleSubst are the bindings floated out+-- from nested matches; see the Let case of match, below+-- data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the , rs_id_subst :: IdSubstEnv -- template variables , rs_binds :: BindWrapper -- Floated bindings- , rs_bndrs :: VarSet -- Variables bound by floated lets+ , rs_bndrs :: [Var] -- Variables bound by floated lets } type BindWrapper = CoreExpr -> CoreExpr@@ -710,57 +742,188 @@ emptyRuleSubst :: RuleSubst emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv- , rs_binds = \e -> e, rs_bndrs = emptyVarSet }+ , rs_binds = \e -> e, rs_bndrs = [] } --- At one stage I tried to match even if there are more--- template args than real args.+----------------------+match_exprs :: RuleMatchEnv -> RuleSubst+ -> [CoreExpr] -- Templates+ -> [CoreExpr] -- Targets+ -> Maybe RuleSubst+-- If the targets are longer than templates, succeed, simply ignoring+-- the leftover targets. This matters in the call in matchN.+--+-- Precondition: corresponding elements of es1 and es2 have the same+-- type, assumuing earlier elements match+-- Example: f :: forall v. v -> blah+-- match_exprs [Type a, y::a] [Type Int, 3]+-- Then, after matching Type a against Type Int,+-- the type of (y::a) matches that of (3::Int)+match_exprs _ subst [] _+ = Just subst+match_exprs renv subst (e1:es1) (e2:es2)+ = do { subst' <- match renv subst e1 e2 MRefl+ ; match_exprs renv subst' es1 es2 }+match_exprs _ _ _ _ = Nothing -- I now think this is probably a bad idea. -- Should the template (map f xs) match (map g)? I think not. -- For a start, in general eta expansion wastes work. -- SLPJ July 99 +{- Note [Casts in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As far as possible we don't want casts in the target to get in the way of+matching. E.g.+* (let bind in e) |> co+* (case e of alts) |> co+* (\ a b. f a b) |> co++In the first two cases we want to float the cast inwards so we can match on+the let/case. This is not important in practice because the Simplifier does+this anyway.++But the third case /is/ important: we don't want the cast to get in the way+of eta-reduction. See Note [Cancel reflexive casts] for a real life example.++The most convenient thing is to make 'match' take an MCoercion argument, thus:++* The main matching function+ match env subst template target mco+ matches template ~ (target |> mco)++* Invariant: typeof( subst(template) ) = typeof( target |> mco )++Note that for applications+ (e1 e2) ~ (d1 d2) |> co+where 'co' is non-reflexive, we simply fail. You might wonder about+ (e1 e2) ~ ((d1 |> co1) d2) |> co2+but the Simplifer pushes the casts in an application to to the+right, if it can, so this doesn't really arise.++Note [Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~+What if we have (f co) in the template, where the 'co' is a coercion+argument to f? Right now we have nothing in place to ensure that a+coercion /argument/ in the template is a variable. We really should,+perhaps by abstracting over that variable.++C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.++For now, though, we simply behave badly, by failing in match_co.+We really should never rely on matching the structure of a coercion+(which is just a proof).++Note [Casts in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the definition+ f x = e,+and SpecConstr on call pattern+ f ((e1,e2) |> co)++We'll make a RULE+ RULE forall a,b,g. f ((a,b)|> g) = $sf a b g+ $sf a b g = e[ ((a,b)|> g) / x ]++So here is the invariant:++ In the template, in a cast (e |> co),+ the cast `co` is always a /variable/.++Matching should bind that variable to an actual coercion, so that we+can use it in $sf. So a Cast on the LHS (the template) calls+match_co, which succeeds when the template cast is a variable -- which+it always is. That is why match_co has so few cases.++See also+* Note [Coercion arguments]+* Note [Matching coercion variables] in GHC.Core.Unify.+* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils:+ sm_cast_swizzle is switched off in the template of a RULE+-}++---------------------- match :: RuleMatchEnv- -> RuleSubst+ -> RuleSubst -- Substitution applies to template only -> CoreExpr -- Template -> CoreExpr -- Target+ -> MCoercion -> Maybe RuleSubst +-- Postcondition (TypeInv): if matching succeeds, then+-- typeof( subst(template) ) = typeof( target |> mco )+-- But this is /not/ a pre-condition! The types of template and target+-- may differ, see the (App e1 e2) case+--+-- Invariant (CoInv): if mco :: ty ~ ty, then it is MRefl, not MCo co+-- See Note [Cancel reflexive casts]+--+-- See the notes with Unify.match, which matches types+-- Everything is very similar for terms+++------------------------ Ticks --------------------- -- We look through certain ticks. See Note [Tick annotations in RULE matching]-match renv subst e1 (Tick t e2)- | tickishFloatable t- = match renv subst' e1 e2- where subst' = subst { rs_binds = rs_binds subst . mkTick t }-match renv subst (Tick t e1) e2- -- Ignore ticks in rule template.+match renv subst e1 (Tick t e2) mco | tickishFloatable t- = match renv subst e1 e2-match _ _ e@Tick{} _+ = match renv subst' e1 e2 mco+ | otherwise+ = Nothing+ where+ subst' = subst { rs_binds = rs_binds subst . mkTick t }++match renv subst e@(Tick t e1) e2 mco+ | tickishFloatable t -- Ignore floatable ticks in rule template.+ = match renv subst e1 e2 mco+ | otherwise = pprPanic "Tick in rule" (ppr e) --- See the notes with Unify.match, which matches types--- Everything is very similar for terms+------------------------ Types ---------------------+match renv subst (Type ty1) (Type ty2) _mco+ = match_ty renv subst ty1 ty2 --- Interesting examples:--- Consider matching--- \x->f against \f->f--- When we meet the lambdas we must remember to rename f to f' in the--- second expression. The RnEnv2 does that.------ Consider matching--- forall a. \b->b against \a->3--- We must rename the \a. Otherwise when we meet the lambdas we--- might substitute [a/b] in the template, and then erroneously--- succeed in matching what looks like the template variable 'a' against 3.+------------------------ Coercions ---------------------+-- See Note [Coercion argument] for why this isn't really right+match renv subst (Coercion co1) (Coercion co2) MRefl+ = match_co renv subst co1 co2+ -- The MCo case corresponds to matching co ~ (co2 |> co3)+ -- and I have no idea what to do there -- or even if it can occur+ -- Failing seems the simplest thing to do; it's certainly safe. +------------------------ Casts ---------------------+-- See Note [Casts in the template]+-- Note [Casts in the target]+-- Note [Cancel reflexive casts]++match renv subst e1 (Cast e2 co2) mco+ = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco))+ -- checkReflexiveMCo: cancel casts if possible+ -- This is important: see Note [Cancel reflexive casts]++match renv subst (Cast e1 co1) e2 mco+ = -- See Note [Casts in the template]+ do { let co2 = case mco of+ MRefl -> mkRepReflCo (exprType e2)+ MCo co2 -> co2+ ; subst1 <- match_co renv subst co1 co2+ -- If match_co succeeds, then (exprType e1) = (exprType e2)+ -- Hence the MRefl in the next line+ ; match renv subst1 e1 e2 MRefl }++------------------------ Literals ---------------------+match _ subst (Lit lit1) (Lit lit2) mco+ | lit1 == lit2+ = ASSERT2(isReflMCo mco, ppr mco)+ Just subst++------------------------ Variables --------------------- -- The Var case follows closely what happens in GHC.Core.Unify.match-match renv subst (Var v1) e2- = match_var renv subst v1 e2+match renv subst (Var v1) e2 mco+ = match_var renv subst v1 (mkCastMCo e2 mco) -match renv subst e1 (Var v2) -- Note [Expanding variables]- | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]+match renv subst e1 (Var v2) mco -- Note [Expanding variables]+ | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')- = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'+ = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco where v2' = lookupRnInScope rn_env v2 rn_env = rv_lcl renv@@ -769,19 +932,77 @@ -- No need to apply any renaming first (hence no rnOccR) -- because of the not-inRnEnvR -match renv subst e1 (Let bind e2)+------------------------ Applications ---------------------+-- Note the match on MRefl! We fail if there is a cast in the target+-- (e1 e2) ~ (d1 d2) |> co+-- See Note [Cancel reflexive casts]: in the Cast equations for 'match'+-- we agressively ensure that if MCo is reflective, it really is MRefl.+match renv subst (App f1 a1) (App f2 a2) MRefl+ = do { subst' <- match renv subst f1 f2 MRefl+ ; match renv subst' a1 a2 MRefl }++------------------------ Float lets ---------------------+match renv subst e1 (Let bind e2) mco | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ not (isJoinBind bind) -- can't float join point out of argument position , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]- = match (renv { rv_fltR = flt_subst' })+ = match (renv { rv_fltR = flt_subst'+ , rv_lcl = rv_lcl renv `extendRnInScopeSetList` new_bndrs })+ -- We are floating the let-binding out, as if it had enclosed+ -- the entire target from Day 1. So we must add its binders to+ -- the in-scope set (#20200) (subst { rs_binds = rs_binds subst . Let bind'- , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })- e1 e2+ , rs_bndrs = new_bndrs ++ rs_bndrs subst })+ e1 e2 mco+ | otherwise+ = Nothing where- flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)+ in_scope = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst+ -- in_scope: see (4) in Note [Matching lets]+ flt_subst = rv_fltR renv `setInScope` in_scope (flt_subst', bind') = substBind flt_subst bind- new_bndrs = bindersOf bind'+ new_bndrs = bindersOf bind' +------------------------ Lambdas ---------------------+match renv subst (Lam x1 e1) e2 mco+ | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco)+ -- See Note [Lambdas in the template]+ = let renv' = rnMatchBndr2 renv x1 x2+ subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }+ in match renv' subst' e1 e2' MRefl++match renv subst e1 e2@(Lam {}) mco+ | Just (renv', e2') <- eta_reduce renv e2 -- See Note [Eta reduction in the target]+ = match renv' subst e1 e2' mco++{- Note [Lambdas in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we match+ Template: (\x. blah_template)+ Target: (\y. blah_target)+then we want to match inside the lambdas, using rv_lcl to match up+x and y.++But what about this?+ Template (\x. (blah1 |> cv))+ Target (\y. blah2) |> co++This happens quite readily, because the Simplifier generally moves+casts outside lambdas: see Note [Casts and lambdas] in+GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co`+back inside, which is what `exprIsLambda_maybe` does. But we've+stripped off that cast, so now we need to put it back, hence mkCastMCo.++Unlike the target, where we attempt eta-reduction, we do not attempt+to eta-reduce the template, and may therefore fail on+ Template: \x. f True x+ Target f True++It's not especially easy to deal with eta reducing the template,+and never happens, because no one write eta-expanded left-hand-sides.+-}++------------------------ Case expression --------------------- {- Disabled: see Note [Matching cases] below match renv (tv_subst, id_subst, binds) e1 (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])@@ -797,113 +1018,161 @@ case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] -} -match _ subst (Lit lit1) (Lit lit2)- | lit1 == lit2- = Just subst+match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco+ = do { subst1 <- match_ty renv subst ty1 ty2+ ; subst2 <- match renv subst1 e1 e2 MRefl+ ; let renv' = rnMatchBndr2 renv x1 x2+ ; match_alts renv' subst2 alts1 alts2 mco -- Alts are both sorted+ } -match renv subst (App f1 a1) (App f2 a2)- = do { subst' <- match renv subst f1 f2- ; match renv subst' a1 a2 }+-- Everything else fails+match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $+ Nothing -match renv subst (Lam x1 e1) e2- | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2- = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2- , rv_fltR = delBndr (rv_fltR renv) x2 }- subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }- in match renv' subst' e1 e2+-------------+eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)+-- See Note [Eta reduction in the target]+eta_reduce renv e@(Lam {})+ = go renv id [] e+ where+ go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr+ -> Maybe (RuleMatchEnv, CoreExpr)+ go renv bw vs (Let b e) = go renv (bw . Let b) vs e -match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)- = do { subst1 <- match_ty renv subst ty1 ty2- ; subst2 <- match renv subst1 e1 e2- ; let renv' = rnMatchBndr2 renv subst x1 x2- ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted- }+ go renv bw vs (Lam v e) = go renv' bw (v':vs) e+ where+ (rn_env', v') = rnBndrR (rv_lcl renv) v+ renv' = renv { rv_lcl = rn_env' } -match renv subst (Type ty1) (Type ty2)- = match_ty renv subst ty1 ty2-match renv subst (Coercion co1) (Coercion co2)- = match_co renv subst co1 co2+ go renv bw (v:vs) (App f arg)+ | Var a <- arg, v == rnOccR (rv_lcl renv) a+ = go renv bw vs f -match renv subst (Cast e1 co1) (Cast e2 co2)- = do { subst1 <- match_co renv subst co1 co2- ; match renv subst1 e1 e2 }+ | Type ty <- arg, Just tv <- getTyVar_maybe ty+ , v == rnOccR (rv_lcl renv) tv+ = go renv bw vs f --- Everything else fails-match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $- Nothing+ go renv bw [] e = Just (renv, bw e)+ go _ _ (_:_) _ = Nothing +eta_reduce _ _ = Nothing++{- Note [Eta reduction in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are faced with this (#19790)+ Template {x} f x+ Target (\a b c. let blah in f x a b c)++You might wonder why we have an eta-expanded target (see first subtle+point below), but regardless of how it came about, we'd like+eta-expansion not to impede matching.++So eta_reduce does on-the-fly eta-reduction of the target expression.+Given (\a b c. let blah in e a b c), it returns (let blah in e).++Subtle points:+* Consider a target: \x. f <expensive> x+ In the main eta-reducer we do not eta-reduce this, because doing so+ might reduce the arity of the expression (from 1 to zero, because of+ <expensive>). But for rule-matching we /do/ want to match template+ (f a) against target (\x. f <expensive> x), with a := <expensive>++ This is a compelling reason for not relying on the Simplifier's+ eta-reducer.++* The Lam case of eta_reduce renames as it goes. Consider+ (\x. \x. f x x). We should not eta-reduce this. As we go we rename+ the first x to x1, and the second to x2; then both argument x's are x2.++* eta_reduce does /not/ need to check that the bindings 'blah'+ and expression 'e' don't mention a b c; but it /does/ extend the+ rv_lcl RnEnv2 (see rn_bndr in eta_reduce).+ * If 'blah' mentions the binders, the let-float rule won't+ fire; and+ * if 'e' mentions the binders we we'll also fail to match+ e.g. because of the exprFreeVars test in match_tmpl_var.++ Example: Template: {x} f a -- Some top-level 'a'+ Target: (\a b. f a a b) -- The \a shadows top level 'a'+ Then eta_reduce will /succeed/, with+ (rnEnvR = [a :-> a'], f a)+ The returned RnEnv will map [a :-> a'], where a' is fresh. (There is+ no need to rename 'b' because (in this example) it is not in scope.+ So it's as if we'd returned (f a') from eta_reduce; the renaming applied+ to the target is simply deferred.++Note [Cancel reflexive casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is an example (from #19790) which we want to catch+ (f x) ~ (\a b. (f x |> co) a b) |> sym co+where+ f :: Int -> Stream+ co :: Stream ~ T1 -> T2 -> T3++when we eta-reduce (\a b. blah a b) to 'blah', we'll get+ (f x) ~ (f x) |> co |> sym co++and we really want to spot that the co/sym-co cancels out.+Hence+ * We keep an invariant that the MCoercion is always MRefl+ if the MCoercion is reflextve+ * We maintain this invariant via the call to checkReflexiveMCo+ in the Cast case of 'match'.+-}+ ------------- match_co :: RuleMatchEnv -> RuleSubst -> Coercion -> Coercion -> Maybe RuleSubst+-- We only match if the template is a coercion variable or Refl:+-- see Note [Casts in the template]+-- Like 'match' it is /not/ guaranteed that+-- coercionKind template = coercionKind target+-- But if match_co succeeds, it /is/ guaranteed that+-- coercionKind (subst template) = coercionKind target+ match_co renv subst co1 co2 | Just cv <- getCoVar_maybe co1 = match_var renv subst cv (Coercion co2)+ | Just (ty1, r1) <- isReflCo_maybe co1 = do { (ty2, r2) <- isReflCo_maybe co2 ; guard (r1 == r2) ; match_ty renv subst ty1 ty2 }-match_co renv subst co1 co2- | Just (tc1, cos1) <- splitTyConAppCo_maybe co1- = case splitTyConAppCo_maybe co2 of- Just (tc2, cos2)- | tc1 == tc2- -> match_cos renv subst cos1 cos2- _ -> Nothing-match_co renv subst co1 co2- | Just (arg1, res1) <- splitFunCo_maybe co1- = case splitFunCo_maybe co2 of- Just (arg2, res2)- -> match_cos renv subst [arg1, res1] [arg2, res2]- _ -> Nothing-match_co _ _ _co1 _co2- -- Currently just deals with CoVarCo, TyConAppCo and Refl-#if defined(DEBUG)- = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing-#else- = Nothing-#endif -match_cos :: RuleMatchEnv- -> RuleSubst- -> [Coercion]- -> [Coercion]- -> Maybe RuleSubst-match_cos renv subst (co1:cos1) (co2:cos2) =- do { subst' <- match_co renv subst co1 co2- ; match_cos renv subst' cos1 cos2 }-match_cos _ subst [] [] = Just subst-match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing+ | debugIsOn+ = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing+ -- Currently just deals with CoVarCo and Refl + | otherwise+ = Nothing+ --------------rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv-rnMatchBndr2 renv subst x1 x2- = renv { rv_lcl = rnBndr2 rn_env x1 x2+rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv+rnMatchBndr2 renv x1 x2+ = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 , rv_fltR = delBndr (rv_fltR renv) x2 }- where- rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)- -- Typically this is a no-op, but it may matter if- -- there are some floated let-bindings + ------------------------------------------ match_alts :: RuleMatchEnv -> RuleSubst- -> [CoreAlt] -- Template- -> [CoreAlt] -- Target+ -> [CoreAlt] -- Template+ -> [CoreAlt] -> MCoercion -- Target -> Maybe RuleSubst-match_alts _ subst [] []+match_alts _ subst [] [] _ = return subst-match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2)+match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco | c1 == c2- = do { subst1 <- match renv' subst r1 r2- ; match_alts renv subst1 alts1 alts2 }+ = do { subst1 <- match renv' subst r1 r2 mco+ ; match_alts renv subst1 alts1 alts2 mco } where renv' = foldl' mb renv (vs1 `zip` vs2)- mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2+ mb renv (v1,v2) = rnMatchBndr2 renv v1 v2 -match_alts _ _ _ _+match_alts _ _ _ _ _ = Nothing ------------------------------------------@@ -916,8 +1185,8 @@ ------------------------------------------ match_var :: RuleMatchEnv -> RuleSubst- -> Var -- Template- -> CoreExpr -- Target+ -> Var -- Template+ -> CoreExpr -- Target -> Maybe RuleSubst match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) subst v1 e2@@ -926,12 +1195,19 @@ | otherwise -- v1' is not a template variable; check for an exact match with e2 = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR- Var v2 | v1' == rnOccR rn_env v2- -> Just subst+ Var v2 | Just v2' <- rnOccR_maybe rn_env v2+ -> -- v2 was bound by a nested lambda or case+ if v1' == v2' then Just subst+ else Nothing + -- v2 is not bound nestedly; it is free+ -- in the whole expression being matched+ -- So it will be in the InScopeSet for flt_env (#20200) | Var v2' <- lookupIdSubst flt_env v2 , v1' == v2' -> Just subst+ | otherwise+ -> Nothing _ -> Nothing @@ -946,14 +1222,14 @@ match_tmpl_var :: RuleMatchEnv -> RuleSubst -> Var -- Template- -> CoreExpr -- Target+ -> CoreExpr -- Target -> Maybe RuleSubst match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2 | any (inRnEnvR rn_env) (exprFreeVarsList e2)- = Nothing -- Occurs check failure+ = Nothing -- Skolem-escape failure -- e.g. match forall a. (\x-> a x) against (\y. y y) | Just e1' <- lookupVarEnv id_subst v1'@@ -961,22 +1237,12 @@ then Just subst else Nothing - | otherwise- = -- Note [Matching variable types]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- However, we must match the *types*; e.g.- -- forall (c::Char->Int) (x::Char).- -- f (c x) = "RULE FIRED"- -- We must only match on args that have the right type- -- It's actually quite difficult to come up with an example that shows- -- you need type matching, esp since matching is left-to-right, so type- -- args get matched first. But it's possible (e.g. simplrun008) and- -- this is the Right Thing to do- do { subst' <- match_ty renv subst (idType v1') (exprType e2)+ | otherwise -- See Note [Matching variable types]+ = do { subst' <- match_ty renv subst (idType v1') (exprType e2) ; return (subst' { rs_id_subst = id_subst' }) } where -- e2' is the result of applying flt_env to e2- e2' | isEmptyVarSet let_bndrs = e2+ e2' | null let_bndrs = e2 | otherwise = substExpr flt_env e2 id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'@@ -1002,7 +1268,30 @@ where tv_subst = rs_tv_subst subst -{-+{- Note [Matching variable types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching x ~ e, where 'x' is a template variable, we must check that+x's type matches e's type, to establish (TypeInv). For example+ forall (c::Char->Int) (x::Char).+ f (c x) = "RULE FIRED"+We must not match on, say (f (pred (3::Int))).++It's actually quite difficult to come up with an example that shows+you need type matching, esp since matching is left-to-right, so type+args get matched first. But it's possible (e.g. simplrun008) and this+is the Right Thing to do.++An alternative would be to make (TypeInf) into a /pre-condition/. It+is threatened only by the App rule. So when matching an application+(e1 e2) ~ (d1 d2) would be to collect args of the application chain,+match the types of the head, then match arg-by-arg.++However that alternative seems a bit more complicated. And by+matching types at variables we do one match_ty for each template+variable, rather than one for each application chain. Usually there are+fewer template variables, although for simple rules it could be the other+way around.+ Note [Expanding variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another Very Important rule: if the term being matched is a@@ -1031,7 +1320,6 @@ Note [Tick annotations in RULE matching] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- We used to unconditionally look through ticks in both template and expression being matched. This is actually illegal for counting or cost-centre-scoped ticks, because we have no place to put them without@@ -1048,6 +1336,7 @@ cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr + Note [Matching lets] ~~~~~~~~~~~~~~~~~~~~ Matching a let-expression. Consider@@ -1066,40 +1355,58 @@ Here we obviously cannot float the let-binding for w. Hence the use of okToFloat. -There are a couple of tricky points.- (a) What if floating the binding captures a variable?+There are a couple of tricky points:+ (a) What if floating the binding captures a variable that is+ free in the entire expression? f (let v = x+1 in v) v --> NOT! let v = x+1 in f (x+1) v - (b) What if two non-nested let bindings bind the same variable?+ (b) What if the let shadows a local binding?+ f (\v -> (v, let v = x+1 in (v,v))+ --> NOT!+ let v = x+1 in f (\v -> (v, (v,v)))++ (c) What if two non-nested let bindings bind the same variable? f (let v = e1 in b1) (let v = e2 in b2) --> NOT! let v = e1 in let v = e2 in (f b2 b2)- See testsuite test "RuleFloatLet".+ See testsuite test `T4814`. Our cunning plan is this:- * Along with the growing substitution for template variables- we maintain a growing set of floated let-bindings (rs_binds)- plus the set of variables thus bound.+ (1) Along with the growing substitution for template variables+ we maintain a growing set of floated let-bindings (rs_binds)+ plus the set of variables thus bound (rs_bndrs). - * The RnEnv2 in the MatchEnv binds only the local binders- in the term (lambdas, case)+ (2) The RnEnv2 in the MatchEnv binds only the local binders+ in the term (lambdas, case), not the floated let-bndrs. - * When we encounter a let in the term to be matched, we- check that does not mention any locally bound (lambda, case)- variables. If so we fail+ (3) When we encounter a `let` in the term to be matched, in the Let+ case of `match`, we use `okToFloat` to check that it does not mention any+ locally bound (lambda, case) variables. If so we fail. - * We use GHC.Core.Subst.substBind to freshen the binding, using an- in-scope set that is the original in-scope variables plus the- rs_bndrs (currently floated let-bindings). So in (a) above- we'll freshen the 'v' binding; in (b) above we'll freshen- the *second* 'v' binding.+ (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to+ freshen the binding (which, remember (3), mentions no locally+ bound variables), in a lexically-scoped way (via rv_fltR in+ MatchEnv). - * We apply that freshening substitution, in a lexically-scoped- way to the term, although lazily; this is the rv_fltR field.+ The subtle point is that we want an in-scope set for this+ substitution that includes /two/ sets:+ * The in-scope variables at this point, so that we avoid using+ those local names for the floated binding; points (a) and (b) above.+ * All "earlier" floated bindings, so that we avoid using the+ same name for two different floated bindings; point (c) above. + Because we have to compute the in-scope set here, the in-scope set+ stored in `rv_fltR` is always ignored; we leave it only because it's+ convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`)+ rather than storing three separate substitutions. + (5) We apply that freshening substitution, in a lexically-scoped+ way to the term, although lazily; this is the rv_fltR field.++See #4814, which is an issue resulting from getting this wrong.+ Note [Matching cases] ~~~~~~~~~~~~~~~~~~~~~ {- NOTE: This idea is currently disabled. It really only works if@@ -1272,7 +1579,7 @@ not (isJust (match_fn rule_arg arg))] lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars- match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg+ match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl where in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope
compiler/GHC/CoreToStg/Prep.hs view
@@ -164,32 +164,32 @@ ~~~~~~~~~~~~~~~~~~~~~~~ CorePrep does these two transformations: -* Convert empty case to cast with an unsafe coercion+1. Convert empty case to cast with an unsafe coercion (case e of {}) ===> e |> unsafe-co- See Note [Empty case alternatives] in GHC.Core: if the case- alternatives are empty, the scrutinee must diverge or raise an- exception, so we can just dive into it.+ See Note [Empty case alternatives] in GHC.Core: if the case+ alternatives are empty, the scrutinee must diverge or raise an+ exception, so we can just dive into it. - Of course, if the scrutinee *does* return, we may get a seg-fault.- A belt-and-braces approach would be to persist empty-alternative- cases to code generator, and put a return point anyway that calls a- runtime system error function.+ Of course, if the scrutinee *does* return, we may get a seg-fault.+ A belt-and-braces approach would be to persist empty-alternative+ cases to code generator, and put a return point anyway that calls a+ runtime system error function. - Notice that eliminating empty case can lead to an ill-kinded coercion- case error @Int "foo" of {} :: Int#- ===> error @Int "foo" |> unsafe-co- where unsafe-co :: Int ~ Int#- But that's fine because the expression diverges anyway. And it's- no different to what happened before.+ Notice that eliminating empty case can lead to an ill-kinded coercion+ case error @Int "foo" of {} :: Int#+ ===> error @Int "foo" |> unsafe-co+ where unsafe-co :: Int ~ Int#+ But that's fine because the expression diverges anyway. And it's+ no different to what happened before. -* Eliminate unsafeEqualityProof in favour of an unsafe coercion- case unsafeEqualityProof of UnsafeRefl g -> e- ===> e[unsafe-co/g]- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+2. Eliminate unsafeEqualityProof in favour of an unsafe coercion+ case unsafeEqualityProof of UnsafeRefl g -> e+ ===> e[unsafe-co/g]+ See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce - Note that this requiresuse ot substitute 'unsafe-co' for 'g', and- that is the main (current) reason for cpe_tyco_env in CorePrepEnv.- Tiresome, but not difficult.+ Note that this requires us to substitute 'unsafe-co' for 'g', and+ that is the main (current) reason for cpe_tyco_env in CorePrepEnv.+ Tiresome, but not difficult. These transformations get rid of "case clutter", leaving only casts. We are doing no further significant tranformations, so the reasons@@ -197,7 +197,10 @@ the ANF-ery, CoreToStg, and backends, if trivial expressions really do look trivial. #19700 was an example. -In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv).+In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),+The boolean 'b' says whether the unsafe coercion is supposed to be+kind-homogeneous (yes for (2), no for (1). This information is used+/only/ by Lint. Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -307,7 +310,7 @@ -- If we want to generate debug info, we put a source note on the -- worker. This is useful, especially for heap profiling. tick_it name- | debugLevel dflags == 0 = id+ | not (needSourceNotes dflags) = id | RealSrcSpan span _ <- nameSrcSpan name = tick span | Just file <- ml_hs_file mod_loc = tick (span1 file) | otherwise = tick (span1 "???")@@ -827,8 +830,14 @@ -- See Note [Unsafe coercions] cpeRhsE env (Case scrut _ ty []) = do { (floats, scrut') <- cpeRhsE env scrut- ; let ty' = cpSubstTy env ty- co' = mkUnsafeCo Representational (exprType scrut') ty'+ ; let ty' = cpSubstTy env ty+ scrut_ty' = exprType scrut'+ co' = mkUnivCo prov Representational scrut_ty' ty'+ prov = CorePrepProv False+ -- False says that the kinds of two types may differ+ -- E.g. we might cast Int to Int#. This is fine+ -- because the scrutinee is guaranteed to diverge+ ; return (floats, Cast scrut' co') } -- This can give rise to -- Warning: Unsafe coercion: between unboxed and boxed value@@ -842,7 +851,8 @@ -- is dead. It usually is, but see #18227 , [Alt _ [co_var] rhs] <- alts , let Pair ty1 ty2 = coVarTypes co_var- the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+ the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+ prov = CorePrepProv True -- True <=> kind homogeneous env' = extendCoVarEnv env co_var the_co = cpeRhsE env' rhs @@ -1363,9 +1373,6 @@ However, until then we simply add a special case excluding literals from the floating done by cpeArg. -}--mkUnsafeCo :: Role -> Type -> Type -> Coercion-mkUnsafeCo role ty1 ty2 = mkUnivCo CorePrepProv role ty1 ty2 -- | Is an argument okay to CPE? okCpeArg :: CoreExpr -> Bool
compiler/GHC/Driver/Main.hs view
@@ -43,6 +43,7 @@ , Messager, batchMsg , HscStatus (..) , hscIncrementalCompile+ , initModDetails , hscMaybeWriteIface , hscCompileCmmFile @@ -98,6 +99,7 @@ import GHC.Driver.CodeOutput import GHC.Driver.Config import GHC.Driver.Hooks+import GHC.Parser.Errors import GHC.Runtime.Context import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )@@ -143,7 +145,6 @@ import GHC.CoreToStg.Prep import GHC.CoreToStg ( coreToStg ) -import GHC.Parser.Errors import GHC.Parser.Errors.Ppr import GHC.Parser import GHC.Parser.Lexer as Lexer@@ -230,6 +231,7 @@ import Control.DeepSeq (force) import Data.Bifunctor (first, bimap) import GHC.Data.Maybe+import Data.List.NonEmpty (NonEmpty ((:|))) #include "GhclibHsVersions.h" @@ -417,6 +419,14 @@ Nothing -> liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1++ when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do+ case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of+ Nothing -> pure ()+ Just chars ->+ logWarnings $ unitBag $ pprWarning $+ PsWarnBidirectionalFormatChars chars+ let parseMod | HsigFile == ms_hsc_src mod_summary = parseSignature | otherwise = parseModule@@ -474,9 +484,34 @@ hsc_env <- getHscEnv withPlugins hsc_env applyPluginAction res +checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))+checkBidirectionFormatChars start_loc sb+ | containsBidirectionalFormatChar sb = Just $ go start_loc sb+ | otherwise = Nothing+ where+ go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)+ go loc sb+ | atEnd sb = panic "checkBidirectionFormatChars: no char found"+ | otherwise = case nextChar sb of+ (chr, sb)+ | Just desc <- lookup chr bidirectionalFormatChars ->+ (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb+ | otherwise -> go (advancePsLoc loc chr) sb + go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]+ go1 loc sb+ | atEnd sb = []+ | otherwise = case nextChar sb of+ (chr, sb)+ | Just desc <- lookup chr bidirectionalFormatChars ->+ (loc, chr, desc) : go1 (advancePsLoc loc chr) sb+ | otherwise -> go1 (advancePsLoc loc chr) sb++ -- ----------------------------------------------------------------------------- -- | If the renamed source has been kept, extract it. Dump it if requested.++ extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result@@ -813,18 +848,7 @@ -- We didn't need to do any typechecking; the old interface -- file on disk was good enough. Left iface -> do- -- Knot tying! See Note [Knot-tying typecheckIface]- details <- liftIO . fixIO $ \details' -> do- let hsc_env' =- hsc_env {- hsc_HPT = addToHpt (hsc_HPT hsc_env)- (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)- }- -- NB: This result is actually not that useful- -- in one-shot mode, since we're not going to do- -- any further typechecking. It's much more useful- -- in make mode, since this HMI will go into the HPT.- genModDetails hsc_env' iface+ details <- liftIO $ initModDetails hsc_env mod_summary iface return (HscUpToDate iface details, hsc_env') -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had@@ -834,6 +858,67 @@ status <- finish mod_summary tc_result mb_old_hash return (status, hsc_env) +-- Knot tying! See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails+initModDetails hsc_env mod_summary iface =+ fixIO $ \details' -> do+ let hsc_env' =+ hsc_env {+ hsc_HPT = addToHpt (hsc_HPT hsc_env)+ (ms_mod_name mod_summary)+ (HomeModInfo iface details' Nothing)+ }+ -- NB: This result is actually not that useful+ -- in one-shot mode, since we're not going to do+ -- any further typechecking. It's much more useful+ -- in make mode, since this HMI will go into the HPT.+ genModDetails hsc_env' iface+++{-+Note [ModDetails and --make mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An interface file consists of two parts++* The `ModIface` which ends up getting written to disk.+ The `ModIface` is a completely acyclic tree, which can be serialised+ and de-serialised completely straightforwardly. The `ModIface` is+ also the structure that is finger-printed for recompilation control.++* The `ModDetails` which provides a more structured view that is suitable+ for usage during compilation. The `ModDetails` is heavily cyclic:+ An `Id` contains a `Type`, which mentions a `TyCon` that contains kind+ that mentions other `TyCons`; the `Id` also includes an unfolding that+ in turn mentions more `Id`s; And so on.++The `ModIface` can be created from the `ModDetails` and the `ModDetails` from+a `ModIface`.++During tidying, just before interfaces are written to disk,+the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).+Then when GHC needs to restart typechecking from a certain point it can read the+interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).+The key part about the loading is that the ModDetails is regenerated lazily+from the ModIface, so that there's only a detailed in-memory representation+for declarations which are actually used from the interface. This mode is+also used when reading interface files from external packages.++In the old --make mode implementation, the interface was written after compiling a module+but the in-memory ModDetails which was used to compute the ModIface was retained.+The result was that --make mode used much more memory than `-c` mode, because a large amount of+information about a module would be kept in the ModDetails but never used.++The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`+at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that+we only have to keep the `ModIface` decls in memory and then lazily load+detailed representations if needed. It turns out this makes a really big difference+to memory usage, halving maximum memory used in some cases.++See !5492 and #13586+-}+ -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date -- and good unfoldings and other info in the interface file.@@ -887,7 +972,6 @@ return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary,- hscs_mod_details = details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_hash }
compiler/GHC/Driver/Make.hs view
@@ -91,7 +91,6 @@ import GHC.Types.SourceFile import GHC.Types.SourceError import GHC.Types.SrcLoc-import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import GHC.Types.Name@@ -102,7 +101,6 @@ import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.Graph import GHC.Unit.Home.ModInfo @@ -481,11 +479,7 @@ stable_mods@(stable_obj,stable_bco) = checkStability hpt1 mg2_with_srcimps all_home_mods - -- prune bits of the HPT which are definitely redundant now,- -- to save space.- pruned_hpt = pruneHomePackageTable hpt1- (flattenSCCs mg2_with_srcimps)- stable_mods+ pruned_hpt = hpt1 _ <- liftIO $ evaluate pruned_hpt @@ -785,44 +779,6 @@ case outputFile_ dflags of Just _ -> env Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }---- ----------------------------------------------------------------------------------- | Prune the HomePackageTable------ Before doing an upsweep, we can throw away:------ - For non-stable modules:--- - all ModDetails, all linked code--- - all unlinked code that is out of date with respect to--- the source file------ This is VERY IMPORTANT otherwise we'll end up requiring 2x the--- space at the end of the upsweep, because the topmost ModDetails of the--- old HPT holds on to the entire type environment from the previous--- compilation.-pruneHomePackageTable :: HomePackageTable- -> [ModSummary]- -> StableModules- -> HomePackageTable-pruneHomePackageTable hpt summ (stable_obj, stable_bco)- = mapHpt prune hpt- where prune hmi- | is_stable modl = hmi'- | otherwise = hmi'{ hm_details = emptyModDetails }- where- modl = moduleName (mi_module (hm_iface hmi))- hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms- = hmi{ hm_linkable = Nothing }- | otherwise- = hmi- where ms = expectJust "prune" (lookupUFM ms_map modl)-- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]-- is_stable m =- m `elementOfUniqSet` stable_obj ||- m `elementOfUniqSet` stable_bco -- ----------------------------------------------------------------------------- --
compiler/GHC/Driver/Pipeline.hs view
@@ -87,7 +87,6 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface )-import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos ) import GHC.Types.Basic ( SuccessFlag(..) ) import GHC.Types.Target@@ -100,7 +99,6 @@ import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) import GHC.Unit.Module.Deps@@ -258,13 +256,15 @@ return $! HomeModInfo iface hmi_details (Just linkable) (HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location,- hscs_mod_details = hmi_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash }, Interpreter) -> do -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. final_iface <- mkFullIface hsc_env' partial_iface Nothing+ -- Reconstruct the `ModDetails` from the just-constructed `ModIface`+ -- See Note [ModDetails and --make mode]+ hmi_details <- liftIO $ initModDetails hsc_env' summary final_iface liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary) (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location@@ -291,7 +291,7 @@ (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline.- (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env'+ (_, _, Just iface) <- runPipeline StopLn hsc_env' (output_fn, Nothing, Just (HscOut src_flavour mod_name status))@@ -302,6 +302,8 @@ -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename]+ -- See Note [ModDetails and --make mode]+ details <- initModDetails hsc_env' summary iface return $! HomeModInfo iface details (Just linkable) where dflags0 = ms_hspp_opts summary@@ -712,7 +714,7 @@ -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects- -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -> IO (DynFlags, FilePath, Maybe ModIface) -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os@@ -843,7 +845,7 @@ -> FilePath -- ^ Input filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects, if we have one- -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -> IO (DynFlags, FilePath, Maybe ModIface) -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn maybe_loc foreign_os@@ -1372,7 +1374,6 @@ return (RealPhase StopLn, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location,- hscs_mod_details = mod_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash }@@ -1385,12 +1386,7 @@ let dflags = hsc_dflags hsc_env' final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))- let final_mod_details- | gopt Opt_OmitInterfacePragmas dflags- = mod_details- | otherwise = {-# SCC updateModDetailsIdInfos #-}- updateModDetailsIdInfos cg_infos mod_details- setIface final_iface final_mod_details+ setIface final_iface -- See Note [Writing interface files] liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
compiler/GHC/HsToCore/Binds.hs view
@@ -853,10 +853,10 @@ = Left (constructor_msg con) -- See Note [No RULES on datacons] | Just (fn_id, args) <- decompose fun2 args2 , let extra_bndrs = mk_extra_bndrs fn_id args- = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+ = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs -- , text "orig_lhs:" <+> ppr orig_lhs -- , text "lhs1:" <+> ppr lhs1- -- , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs+ -- , text "extra_bndrs:" <+> ppr extra_bndrs -- , text "fn_id:" <+> ppr fn_id -- , text "args:" <+> ppr args]) $ Right (orig_bndrs ++ extra_bndrs, fn_id, args)
compiler/GHC/HsToCore/Coverage.hs view
@@ -1047,17 +1047,13 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes deriving (Eq) -sourceNotesEnabled :: DynFlags -> Bool-sourceNotesEnabled dflags =- (debugLevel dflags > 0) || (gopt Opt_InfoTableMap dflags)- coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags = ifa (breakpointsEnabled dflags) Breakpoints $ ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto) ProfNotes $- ifa (sourceNotesEnabled dflags) SourceNotes []+ ifa (needSourceNotes dflags) SourceNotes [] where ifa f x xs | f = x:xs | otherwise = xs
compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -525,8 +525,11 @@ { vi_id = x , vi_pos = [] , vi_neg = emptyPmAltConSet- -- Case (3) in Note [Strict fields and fields of unlifted type]- , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot+ -- Why not set IsNotBot for unlifted type here?+ -- Because we'd have to trigger an inhabitation test, which we can't.+ -- See case (4) in Note [Strict fields and variables of unlifted type]+ -- in GHC.HsToCore.Pmc.Solver+ , vi_bot = MaybeBot , vi_rcm = emptyRCM } @@ -627,7 +630,7 @@ -- ^ @PhiConCt x K tvs dicts ys@ encodes @K \@tvs dicts ys <- x@, matching @x@ -- against the 'PmAltCon' application @K \@tvs dicts ys@, binding @tvs@, -- @dicts@ and possibly unlifted fields @ys@ in the process.- -- See Note [Strict fields and fields of unlifted type].+ -- See Note [Strict fields and variables of unlifted type]. | PhiNotConCt !Id !PmAltCon -- ^ @PhiNotConCt x K@ encodes "x ≁ K", asserting that @x@ can't be headed -- by @K@.@@ -749,9 +752,13 @@ case bot of IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction! IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do- MaybeBot -> do -- We add x ~ ⊥- let vi' = vi{ vi_bot = IsBot }- pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } }+ MaybeBot -> -- We add x ~ ⊥+ -- Case (3) in Note [Strict fields and variables of unlifted type]+ if isUnliftedType (idType x)+ then mzero -- unlifted vars can never be ⊥+ else do+ let vi' = vi{ vi_bot = IsBot }+ pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } -- | Adds the constraint @x ~/ ⊥@ to 'Nabla'. Quite similar to 'addNotConCt', -- but only cares for the ⊥ "constructor".@@ -1168,12 +1175,12 @@ Note [Strict fields and variables of unlifted type] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Binders of unlifted type (and strict fields) are unlifted by construction;-they are conceived with an implicit @≁⊥@ constraint to begin with. Hence,-desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned by strict fields,-since the forcing happens *before* pattern matching.-And the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd'-have complex binding semantics (binding type constraints and unlifted fields),-so unliftedness semantics are entirely confined to the oracle.+they are conceived with an implicit (but delayed checked) @≁⊥@ constraint to+begin with. Hence, desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned+by strict fields, since the forcing happens *before* pattern matching. And+the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd' have+complex binding semantics (binding type constraints and unlifted fields), so+unliftedness semantics are entirely confined to the oracle. These are the moving parts: @@ -1204,11 +1211,18 @@ constructor constraint. 3. The preceding points handle unlifted constructor fields, but there also- are regular binders of unlifted type.- Since the oracle as implemented has no notion of scoping and bindings,- we can't know *when* an unlifted variable comes into scope. But that's- not actually a problem, because we can just add the @x ≁ ⊥@ to the- 'emptyVarInfo' when we first encounter it.+ are regular binders of unlifted type. We simply fail in 'addBotCt' for+ any binder of unlifted type.+ It would be enough to check for unliftedness once, when the binder comes+ into scope, but we haven't really a way to track that.++ 4. Why not start an 'emptyVarInfo' of unlifted type with @vi_bot = IsNotBot@?+ Because then we'd need to trigger an inhabitation test, because the var+ might actually be void to begin with. But we can't trigger the test from+ 'emptyVarInfo'.+ Historically, that is what we did and not doing the test led to #20631,+ where 'addNotBotCt' trivially succeeded, because the 'VarInfo' already+ said 'IsNotBot', implying that a prior inhabitation test succeeded. -} -------------------------
compiler/GHC/Iface/Load.hs view
@@ -615,6 +615,7 @@ dontLeakTheHPT :: IfL a -> IfL a dontLeakTheHPT thing_inside = do+ dflags <- getDynFlags let cleanTopEnv HscEnv{..} = let@@ -640,9 +641,15 @@ , hsc_HPT = hpt , .. } - updTopEnv cleanTopEnv $ do- !_ <- getTopEnv -- force the updTopEnv- thing_inside+ cleanGblEnv gbl+ | ghcMode dflags == OneShot = gbl+ | otherwise = gbl { if_rec_types = Nothing }++ updGblEnv cleanGblEnv $+ updTopEnv cleanTopEnv $ do+ !_ <- getTopEnv -- force the updTopEnv+ !_ <- getGblEnv+ thing_inside -- | Returns @True@ if a 'ModIface' comes from an external package.
− compiler/GHC/Iface/UpdateIdInfos.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}--module GHC.Iface.UpdateIdInfos- ( updateModDetailsIdInfos- ) where--import GHC.Prelude--import GHC.Core-import GHC.Core.InstEnv--import GHC.StgToCmm.Types (CgInfos (..))--import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Var-import GHC.Types.TypeEnv-import GHC.Types.TyThing--import GHC.Unit.Module.ModDetails--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--#include "GhclibHsVersions.h"---- | Update CafInfos and LFInfos of all occurrences (in rules, unfoldings, class--- instances).------ See Note [Conveying CAF-info and LFInfo between modules] in--- GHC.StgToCmm.Types.-updateModDetailsIdInfos- :: CgInfos- -> ModDetails -- ^ ModDetails to update- -> ModDetails--updateModDetailsIdInfos cg_infos mod_details =- let- ModDetails{ md_types = type_env -- for unfoldings- , md_insts = insts- , md_rules = rules- } = mod_details-- -- type TypeEnv = NameEnv TyThing- type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env- -- NB: Knot-tied! The result, type_env', is passed right back into into- -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in- -- IdInfos, etc) can be looked up in the tidied env-- !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts- !rules' = strictMap (updateRuleIdInfos type_env') rules- in- mod_details{ md_types = type_env'- , md_insts = insts'- , md_rules = rules'- }------------------------------------------------------------------------------------- Rules-----------------------------------------------------------------------------------updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule-updateRuleIdInfos _ rule@BuiltinRule{} = rule-updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }------------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst-updateInstIdInfos type_env cg_infos =- updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)------------------------------------------------------------------------------------- TyThings-----------------------------------------------------------------------------------updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing--updateTyThingIdInfos type_env cg_infos (AnId id) =- AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))--updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom------------------------------------------------------------------------------------- Unfoldings-----------------------------------------------------------------------------------updateIdUnfolding :: TypeEnv -> Id -> Id-updateIdUnfolding type_env id =- case idUnfolding id of- CoreUnfolding{ .. } ->- setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }- DFunUnfolding{ .. } ->- setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }- _ -> id------------------------------------------------------------------------------------- Expressions-----------------------------------------------------------------------------------updateIdInfo :: CgInfos -> Id -> Id-updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =- let- not_caffy = elemNameSet (idName id) non_cafs- mb_lf_info = lookupNameEnv lf_infos (idName id)-- id1 = if not_caffy then setIdCafInfo id NoCafRefs else id- id2 = case mb_lf_info of- Nothing -> id1- Just lf_info -> setIdLFInfo id1 lf_info- in- id2------------------------------------------------------------------------------------updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr--- Update occurrences of GlobalIds as directed by 'env'--- The 'env' maps a GlobalId to a version with accurate CAF info--- (and in due course perhaps other back-end-related info)-updateGlobalIds env e = go env e- where- go_id :: NameEnv TyThing -> Id -> Id- go_id env var =- case lookupNameEnv env (varName var) of- Nothing -> var- Just (AnId id) -> id- Just other -> pprPanic "UpdateIdInfos.updateGlobalIds" $- text "Found a non-Id for Id Name" <+> ppr (varName var) $$- nest 4 (text "Id:" <+> ppr var $$- text "TyThing:" <+> ppr other)-- go :: NameEnv TyThing -> CoreExpr -> CoreExpr- go env (Var v) = Var (go_id env v)- go _ e@Lit{} = e- go env (App e1 e2) = App (go env e1) (go env e2)- go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))- go env (Let bs e) = Let (go_binds env bs) (go env e)- go env (Case e b ty alts) =- assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))- where- go_alt (Alt k bs e) = assertNotInNameEnv env bs (Alt k bs (go env e))- go env (Cast e c) = Cast (go env e) c- go env (Tick t e) = Tick t (go env e)- go _ e@Type{} = e- go _ e@Coercion{} = e-- go_binds :: NameEnv TyThing -> CoreBind -> CoreBind- go_binds env (NonRec b e) =- assertNotInNameEnv env [b] (NonRec b (go env e))- go_binds env (Rec prs) =- assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))---- In `updateGlobaLIds` Names of local binders should not shadow Name of--- globals. This assertion is to check that.-assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b-assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x
compiler/GHC/IfaceToCore.hs view
@@ -1421,6 +1421,7 @@ tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str+tcIfaceUnivCoProv (IfaceCorePrepProv b) = return $ CorePrepProv b {- ************************************************************************@@ -1536,9 +1537,9 @@ tcIfaceExpr (IfaceTick tickish expr) = do expr' <- tcIfaceExpr expr -- If debug flag is not set: Ignore source notes- dbgLvl <- fmap debugLevel getDynFlags+ need_notes <- needSourceNotes <$> getDynFlags case tickish of- IfaceSource{} | dbgLvl == 0+ IfaceSource{} | not (need_notes) -> return expr' _otherwise -> do tickish' <- tcIfaceTickish tickish
compiler/GHC/Linker/Static.hs view
@@ -218,7 +218,8 @@ -- like -- ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog -- on x86.- ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&+ ++ (if not (gopt Opt_CompactUnwind dflags) &&+ toolSettings_ldSupportsCompactUnwind toolSettings' && not staticLink && (platformOS platform == OSDarwin) && case platformArch platform of
compiler/GHC/Llvm/Ppr.hs view
@@ -220,7 +220,8 @@ BranchIf cond ifT ifF -> ind $ ppBranchIf opts cond ifT ifF Comment comments -> ind $ ppLlvmComments comments MkLabel label -> ppLlvmBlockLabel label- Store value ptr -> ind $ ppStore opts value ptr+ Store value ptr align+ -> ind $ ppStore opts value ptr align Switch scrut def tgs -> ind $ ppSwitch opts scrut def tgs Return result -> ind $ ppReturn opts result Expr expr -> ind $ ppLlvmExpression opts expr@@ -243,7 +244,7 @@ ExtractV struct idx -> ppExtractV opts struct idx Insert vec elt idx -> ppInsert opts vec elt idx GetElemPtr inb ptr indexes -> ppGetElementPtr opts inb ptr indexes- Load ptr -> ppLoad opts ptr+ Load ptr align -> ppLoad opts ptr align ALoad ord st ptr -> ppALoad opts ord st ptr Malloc tp amount -> ppMalloc opts tp amount AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering@@ -366,20 +367,16 @@ text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord --- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but--- we have no way of guaranteeing that this is true with GHC (we would need to--- modify the layout of the stack and closures, change the storage manager,--- etc.). So, we blindly tell LLVM that *any* vector store or load could be--- unaligned. In the future we may be able to guarantee that certain vector--- access patterns are aligned, in which case we will need a more granular way--- of specifying alignment. -ppLoad :: LlvmOpts -> LlvmVar -> SDoc-ppLoad opts var = text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align+ppLoad :: LlvmOpts -> LlvmVar -> Maybe Int -> SDoc+ppLoad opts var alignment =+ text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align where derefType = pLower $ getVarType var- align | isVector . pLower . getVarType $ var = text ", align 1"- | otherwise = empty+ align =+ case alignment of+ Just n -> text ", align" <+> ppr n+ Nothing -> empty ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc ppALoad opts ord st var =@@ -391,14 +388,14 @@ in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded <+> ppSyncOrdering ord <> align -ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc-ppStore opts val dst- | isVecPtrVar dst = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <>- comma <+> text "align 1"- | otherwise = text "store" <+> ppVar opts val <> comma <+> ppVar opts dst+ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> LMAlign -> SDoc+ppStore opts val dst alignment =+ text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align where- isVecPtrVar :: LlvmVar -> Bool- isVecPtrVar = isVector . pLower . getVarType+ align =+ case alignment of+ Just n -> text ", align" <+> ppr n+ Nothing -> empty ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
compiler/GHC/Llvm/Syntax.hs view
@@ -150,7 +150,7 @@ * value: Variable/Constant to store. * ptr: Location to store the value in -}- | Store LlvmVar LlvmVar+ | Store LlvmVar LlvmVar LMAlign {- | Multiway branch@@ -252,7 +252,7 @@ {- | Load the value at location ptr -}- | Load LlvmVar+ | Load LlvmVar LMAlign {- | Atomic load of the value at location ptr
compiler/GHC/Stg/Debug.hs view
@@ -62,7 +62,14 @@ collectStgRhs :: Id -> StgRhs -> M StgRhs collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do- e' <- collectExpr e+ let+ name = idName bndr+ -- If the name has a span, use that initially as the source position in-case+ -- we don't get anything better.+ with_span = case nameSrcSpan name of+ RealSrcSpan pos _ -> withSpan (pos, occNameString (getOccName name))+ _ -> id+ e' <- with_span $ collectExpr e recordInfo bndr e' return $ StgRhsClosure ext cc us bs e' collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -152,7 +152,7 @@ let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src- False -> CmmStore baseAddr src+ False -> CmmStore baseAddr src NaturallyAligned other_stmt -> other_stmt fixExpr expr = case expr of@@ -171,7 +171,7 @@ let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr- _other -> CmmLoad baseAddr (globalRegType platform reg)+ _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned CmmRegOff (CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps
compiler/GHC/StgToCmm/Foreign.hs view
@@ -304,10 +304,9 @@ , -- tso->stackobj->sp = Sp; mkStore (cmmOffset platform- (CmmLoad (cmmOffset platform+ (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso))- (tso_stackobj profile))- (bWord platform))+ (tso_stackobj profile))) (stack_SP profile)) spExpr @@ -397,7 +396,7 @@ (widthInBytes $ typeWidth reg_ty) adj_sp = mkAssign spReg (cmmOffset platform spExpr width)- restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty)+ restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned) in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp] emit . catAGraphs =<< mapM save_arg regs @@ -445,7 +444,7 @@ let alloc = CmmMachOp (mo_wordSub platform) [ cmmOffsetW platform hpExpr 1- , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)+ , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) ] alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)@@ -453,7 +452,7 @@ -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Sub W64)- [ CmmLoad alloc_limit b64+ [ CmmLoad alloc_limit b64 NaturallyAligned , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ] @@ -474,9 +473,9 @@ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj;- mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)),+ mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), -- Sp = stack->sp;- mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)),+ mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), -- SpLim = stack->stack + RESERVED_STACK_WORDS; mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) (pc_RESERVED_STACK_WORDS (platformConstants platform))),@@ -487,9 +486,8 @@ open_nursery, -- and load the current cost centre stack from the TSO when profiling: if profileIsProfiling profile- then storeCurCCS- (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))- (tso_CCCS profile)) (ccsType platform))+ then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)+ in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) else mkNop ] @@ -544,12 +542,12 @@ -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr,- mkAssign bdfreereg (CmmLoad (nursery_bdescr_free platform cnreg) (bWord platform)),+ mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), -- Hp = CurrentNursery->free - 1; mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)),+ mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;@@ -557,11 +555,11 @@ (cmmOffsetExpr platform (CmmReg bdstartreg) (cmmOffset platform- (CmmMachOp (mo_wordMul platform) [- CmmMachOp (MO_SS_Conv W32 (wordWidth platform))- [CmmLoad (nursery_bdescr_blocks platform cnreg) b32],- mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))- ])+ (CmmMachOp (mo_wordMul platform)+ [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))+ [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned]+ , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))+ ]) (-1) ) ),@@ -575,7 +573,7 @@ -- tso->alloc_limit += alloc mkStore alloc_limit (CmmMachOp (MO_Add W64)- [ CmmLoad alloc_limit b64+ [ CmmLoad alloc_limit b64 NaturallyAligned , CmmMachOp (mo_WordTo64 platform) [alloc] ]) ]
+ compiler/GHC/StgToCmm/Foreign.hs-boot view
@@ -0,0 +1,6 @@+module GHC.StgToCmm.Foreign where++import GHC.Cmm+import GHC.StgToCmm.Monad++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
compiler/GHC/StgToCmm/Hpc.hs view
@@ -29,7 +29,7 @@ mkTickBox :: Platform -> Module -> Int -> CmmAGraph mkTickBox platform mod n = mkStore tick_box (CmmMachOp (MO_Add W64)- [ CmmLoad tick_box b64+ [ CmmLoad tick_box b64 NaturallyAligned , CmmLit (CmmInt 1 W64) ]) where
compiler/GHC/StgToCmm/Layout.hs view
@@ -89,7 +89,7 @@ ; case sequel of Return -> do { adjustHpBackwards- ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)+ ; let e = cmmLoadGCWord platform (CmmStackSlot Old updfr_off) ; emit (mkReturn profile (entryCode platform e) results updfr_off) } AssignTo regs adjust ->
compiler/GHC/StgToCmm/Monad.hs view
@@ -23,7 +23,7 @@ emit, emitDecl, emitProcWithConvention, emitProcWithStackFrame,- emitOutOfLine, emitAssign, emitStore,+ emitOutOfLine, emitAssign, emitStore, emitStore', emitComment, emitTick, emitUnwind, getCmm, aGraphToGraph, getPlatform, getProfile,@@ -760,8 +760,12 @@ emitAssign :: CmmReg -> CmmExpr -> FCode () emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r)) -emitStore :: CmmExpr -> CmmExpr -> FCode ()-emitStore l r = emitCgStmt (CgStmt (CmmStore l r))+-- | Assumes natural alignment.+emitStore :: CmmExpr -> CmmExpr -> FCode ()+emitStore = emitStore' NaturallyAligned++emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()+emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment)) emit :: CmmAGraph -> FCode () emit ag
compiler/GHC/StgToCmm/Prim.hs view
@@ -2108,13 +2108,20 @@ ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing. +alignmentFromTypes :: CmmType -- ^ element type+ -> CmmType -- ^ index type+ -> AlignmentSpec+alignmentFromTypes ty idx_ty+ | typeWidth ty < typeWidth idx_ty = NaturallyAligned+ | otherwise = Unaligned+ doIndexOffAddrOp :: Maybe MachOp -> CmmType -> [LocalReg] -> [CmmExpr] -> FCode () doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]- = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+ = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx doIndexOffAddrOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp" @@ -2125,7 +2132,8 @@ -> [CmmExpr] -> FCode () doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]- = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+ = let alignment = alignmentFromTypes rep idx_rep+ in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx doIndexOffAddrOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs" @@ -2136,7 +2144,8 @@ -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] = do profile <- getProfile- mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+ doByteArrayBoundsCheck idx addr rep rep+ mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -2148,7 +2157,9 @@ -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] = do profile <- getProfile- mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+ doByteArrayBoundsCheck idx addr idx_rep rep+ let alignment = alignmentFromTypes rep idx_rep+ mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -2159,7 +2170,8 @@ doReadPtrArrayOp res addr idx = do profile <- getProfile platform <- getPlatform- mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx+ doPtrArrayBoundsCheck idx addr+ mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType@@ -2178,6 +2190,8 @@ -> FCode () doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] = do profile <- getProfile+ platform <- getPlatform+ doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val) mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"@@ -2191,14 +2205,18 @@ platform <- getPlatform let ty = cmmExprType platform val hdr_size = arrPtrsHdrSize profile++ doPtrArrayBoundsCheck idx addr+ -- Update remembered set for non-moving collector whenUpdRemSetEnabled- $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)+ $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx) -- This write barrier is to ensure that the heap writes to the object -- referred to by val have happened before we write val into the array. -- See #12469 for details. emitPrimCall [] MO_WriteBarrier [] mkBasicIndexedWrite hdr_size Nothing addr ty idx val+ emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) -- the write barrier. We must write a byte into the mark table: -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]@@ -2206,16 +2224,16 @@ cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) (loadArrPtrsSize profile addr))- (CmmMachOp (mo_wordUShr platform) [idx,- mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])+ (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr-loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)+loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off) where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) platform = profilePlatform profile -mkBasicIndexedRead :: ByteOff -- Initial offset in bytes+mkBasicIndexedRead :: AlignmentSpec+ -> ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast -> CmmType -- Type of element we are accessing -> LocalReg -- Destination@@ -2223,13 +2241,13 @@ -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx+mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx = do platform <- getPlatform- emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+ emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)+mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx = do platform <- getPlatform emitAssign (CmmLocal res) (CmmMachOp cast [- cmmLoadIndexOffExpr platform off ty base idx_ty idx])+ cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx]) mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional value cast@@ -2240,7 +2258,8 @@ -> FCode () mkBasicIndexedWrite off Nothing base idx_ty idx val = do platform <- getPlatform- emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val+ let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty+ emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val mkBasicIndexedWrite off (Just cast) base idx_ty idx val = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val]) @@ -2257,14 +2276,15 @@ = cmmIndexExpr platform width (cmmOffsetB platform base off) idx cmmLoadIndexOffExpr :: Platform+ -> AlignmentSpec -> ByteOff -- Initial offset in bytes -> CmmType -- Type of element we are accessing -> CmmExpr -- Base address -> CmmType -- Type of element by which we are indexing -> CmmExpr -- Index -> CmmExpr-cmmLoadIndexOffExpr platform off ty base idx_ty idx- = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty+cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx+ = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr@@ -2555,6 +2575,12 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do profile <- getProfile platform <- getPlatform++ ifNonZero n $ do+ let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)+ doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8+ doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8+ ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off @@ -2644,6 +2670,12 @@ emitCopyByteArray copy src src_off dst dst_off n = do profile <- getProfile platform <- getPlatform++ ifNonZero n $ do+ let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)+ doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8+ doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8+ let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off@@ -2660,6 +2692,9 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform+ ifNonZero bytes $ do+ let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)+ doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8 src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2678,9 +2713,18 @@ -- Use memcpy (we are allowed to assume the arrays aren't overlapping) profile <- getProfile platform <- getPlatform+ ifNonZero bytes $ do+ let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)+ doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8 dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) +ifNonZero :: CmmExpr -> FCode () -> FCode ()+ifNonZero e it = do+ platform <- getPlatform+ let pred = cmmNeWord platform e (zeroExpr platform)+ code <- getCode it+ emit =<< mkCmmIfThen' pred code (Just False) -- ---------------------------------------------------------------------------- -- Setting byte arrays@@ -2694,6 +2738,9 @@ profile <- getProfile platform <- getPlatform + doByteArrayBoundsCheck off ba b8 b8+ doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8+ let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment@@ -2805,6 +2852,9 @@ dst <- assignTempE dst0 dst_off <- assignTempE dst_off0 + doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src+ doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+ -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n @@ -2871,6 +2921,10 @@ src <- assignTempE src0 dst <- assignTempE dst0 + when (n /= 0) $ do+ doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src+ doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst+ -- Nonmoving collector write barrier emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n @@ -2996,7 +3050,8 @@ doReadSmallPtrArrayOp res addr idx = do profile <- getProfile platform <- getPlatform- mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr+ doSmallPtrArrayBoundsCheck idx addr+ mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr@@ -3008,9 +3063,11 @@ platform <- getPlatform let ty = cmmExprType platform val + doSmallPtrArrayBoundsCheck idx addr+ -- Update remembered set for non-moving collector tmp <- newTemp ty- mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx+ mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) emitPrimCall [] MO_WriteBarrier [] -- #12469@@ -3034,6 +3091,7 @@ doAtomicByteArrayRMW res amop mba idx idx_ty n = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3062,6 +3120,7 @@ doAtomicReadByteArray res mba idx idx_ty = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3089,6 +3148,7 @@ doAtomicWriteByteArray mba idx idx_ty val = do profile <- getProfile platform <- getPlatform+ doByteArrayBoundsCheck idx mba idx_ty idx_ty let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx@@ -3117,7 +3177,8 @@ doCasByteArray res mba idx idx_ty old new = do profile <- getProfile platform <- getPlatform- let width = (typeWidth idx_ty)+ doByteArrayBoundsCheck idx mba idx_ty idx_ty+ let width = typeWidth idx_ty addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall@@ -3225,6 +3286,74 @@ [ res ] (MO_Ctz width) [ x ]++---------------------------------------------------------------------------+-- Array bounds checking+---------------------------------------------------------------------------++doBoundsCheck :: CmmExpr -- ^ accessed index+ -> CmmExpr -- ^ array size (in elements)+ -> FCode ()+doBoundsCheck idx sz = do+ dflags <- getDynFlags+ platform <- getPlatform+ when (gopt Opt_DoBoundsChecking dflags) (doCheck platform)+ where+ doCheck platform = do+ boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []+ emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)+ where+ uGE = cmmUGeWord platform+ and = cmmAndWord platform+ zero = zeroExpr platform+ ne = cmmNeWord platform+ isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero++-- We want to make sure that the array size computation is pushed into the+-- Opt_DoBoundsChecking check to avoid regregressing compiler performance when+-- it's disabled.+{-# INLINE doBoundsCheck #-}++doPtrArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in bytes)+ -> CmmExpr -- ^ pointer to @StgMutArrPtrs@+ -> FCode ()+doPtrArrayBoundsCheck idx arr = do+ profile <- getProfile+ platform <- getPlatform+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)+ doBoundsCheck idx sz++doSmallPtrArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in bytes)+ -> CmmExpr -- ^ pointer to @StgMutArrPtrs@+ -> FCode ()+doSmallPtrArrayBoundsCheck idx arr = do+ profile <- getProfile+ platform <- getPlatform+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)+ doBoundsCheck idx sz++doByteArrayBoundsCheck+ :: CmmExpr -- ^ accessed index (in elements)+ -> CmmExpr -- ^ pointer to @StgArrBytes@+ -> CmmType -- ^ indexing type+ -> CmmType -- ^ element type+ -> FCode ()+doByteArrayBoundsCheck idx arr idx_ty elem_ty = do+ profile <- getProfile+ platform <- getPlatform+ let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)+ sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)+ elem_sz = widthInBytes $ typeWidth elem_ty+ idx_sz = widthInBytes $ typeWidth idx_ty+ -- Ensure that the last byte of the access is within the array+ idx_bytes = cmmOffsetB platform+ (cmmMulWord platform idx (mkIntExpr platform idx_sz))+ (elem_sz - 1)+ doBoundsCheck idx_bytes sz --------------------------------------------------------------------------- -- Pushing to the update remembered set
compiler/GHC/StgToCmm/Prof.hs view
@@ -82,7 +82,7 @@ costCentreFrom :: Platform -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure-costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform)+costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) NaturallyAligned -- | The profiling header words in a static closure staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]@@ -397,7 +397,7 @@ -- don't forget to subtract node's tag ldv_wd = ldvWord platform cl_ptr new_ldv_wd = cmmOrWord platform- (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))+ (cmmAndWord platform (cmmLoadBWord platform ldv_wd) (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) ifProfiling $@@ -411,7 +411,8 @@ loadEra :: Platform -> CmmExpr loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))- (cInt platform)]+ (cInt platform)+ NaturallyAligned] -- | Takes the address of a closure, and returns -- the address of the LDV word in the closure
compiler/GHC/StgToCmm/Ticky.hs view
@@ -109,6 +109,7 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad+import {-# SOURCE #-} GHC.StgToCmm.Foreign ( emitPrimCall ) import GHC.Stg.Syntax import GHC.Cmm.Expr@@ -337,30 +338,46 @@ already_registered <- tickyAllocdIsOn when (not already_registered) $ registerTickyCtr ctr_lbl +-- | Register a ticky counter.+--+-- It's important that this does not race with other entries of the same+-- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also+-- need to make sure that this is reasonably efficient. Consequently, we first+-- perform a normal load of the counter's "registered" flag to check whether+-- registration is necessary. If so, then we do a compare-and-swap to lock the+-- counter for registration and use an atomic-exchange to add the counter to the list.+--+-- @+-- if ( f_ct.registeredp == 0 ) {+-- if (cas(f_ct.registeredp, 0, 1) == 0) {+-- old_head = xchg(ticky_entry_ctrs, f_ct);+-- f_ct.link = old_head;+-- }+-- }+-- @ registerTickyCtr :: CLabel -> FCode ()--- Register a ticky counter--- if ( ! f_ct.registeredp ) {--- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */--- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */--- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do platform <- getPlatform- let- constants = platformConstants platform- -- krc: code generator doesn't handle Not, so we test for Eq 0 instead- test = CmmMachOp (MO_Eq (wordWidth platform))- [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl- (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform),- zeroExpr platform]- register_stmts- = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants)))- (CmmLoad ticky_entry_ctrs (bWord platform))- , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)- , mkStore (CmmLit (cmmLabelOffB ctr_lbl- (pc_OFFSET_StgEntCounter_registeredp constants)))- (mkIntExpr platform 1) ]- ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))- emit =<< mkCmmIfThen test (catAGraphs register_stmts)+ let constants = platformConstants platform+ word_width = wordWidth platform+ registeredp = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_registeredp constants))++ register_stmts <- getCode $ do+ old_head <- newTemp (bWord platform)+ let ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))+ link = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))+ emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl]+ emitStore link (CmmReg $ CmmLocal old_head)++ cas_test <- getCode $ do+ old <- newTemp (bWord platform)+ emitPrimCall [old] (MO_Cmpxchg word_width)+ [registeredp, zeroExpr platform, mkIntExpr platform 1]+ let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform)+ emit =<< mkCmmIfThen locked register_stmts++ let test = cmmEqWord platform (cmmLoadBWord platform registeredp) (zeroExpr platform)+ emit =<< mkCmmIfThen test cas_test tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode () tickyReturnOldCon arity
compiler/GHC/StgToCmm/Utils.hs view
@@ -146,18 +146,20 @@ addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl)) +-- | @addToMem rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. addToMem :: CmmType -- rep of the counter- -> CmmExpr -- Address+ -> CmmExpr -- Naturally-aligned address -> Int -- What to add (a word) -> CmmAGraph addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep))) +-- | @addToMemE rep ptr n@ adds @n@ to the integer pointed-to by @ptr@. addToMemE :: CmmType -- rep of the counter- -> CmmExpr -- Address+ -> CmmExpr -- Naturally-aligned address -> CmmExpr -- What to add (a word-typed expression) -> CmmAGraph addToMemE rep ptr n- = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+ = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep NaturallyAligned, n]) -------------------------------------------------------------------------@@ -177,7 +179,8 @@ (CmmLoad (cmmOffsetB platform (CmmReg (CmmLocal base)) (offset - tag))- (localRegType reg))+ (localRegType reg)+ NaturallyAligned) ------------------------------------------------------------------------- --@@ -188,7 +191,7 @@ tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr tagToClosure platform tycon tag- = CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)+ = cmmLoadBWord platform (cmmOffsetExprW platform closure_tbl tag) where closure_tbl = CmmLit (CmmLabel lbl) lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs @@ -281,7 +284,9 @@ callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerRestoreGlobalReg platform reg = mkAssign (CmmGlobal reg)- (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg))+ (CmmLoad (get_GlobalReg_addr platform reg)+ (globalRegType platform reg)+ NaturallyAligned) -------------------------------------------------------------------------@@ -330,8 +335,7 @@ -- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { platform <- getPlatform- ; uniq <- newUnique- ; let reg = LocalReg uniq (cmmExprType platform e)+ ; reg <- newTemp (cmmExprType platform e) ; emitAssign (CmmLocal reg) e ; return reg } @@ -615,7 +619,7 @@ platform <- getPlatform do_it <- getCode code let- enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)+ enabled = cmmLoadBWord platform (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) zero = zeroExpr platform is_enabled = cmmNeWord platform enabled zero the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
compiler/GHC/SysTools/Info.hs view
@@ -142,7 +142,7 @@ -- ELF specific flag, see Note [ELF needed shared libs] return (GnuGold [Option "-Wl,--no-as-needed"]) - | any ("LLD" `isPrefixOf`) stdo =+ | any (\line -> "LLD" `isPrefixOf` line || "LLD" `elem` words line) stdo = return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs] "-Wl,--no-as-needed"])
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -1628,11 +1628,14 @@ ==> instance (Lift a) => Lift (Foo a) where- lift (Foo a) = [| Foo a |]- lift ((:^:) u v) = [| (:^:) u v |]+ lift (Foo a) = [| Foo $(lift a) |]+ lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |] - liftTyped (Foo a) = [|| Foo a ||]- liftTyped ((:^:) u v) = [|| (:^:) u v ||]+ liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]+ liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]++Note that we use explicit splices here in order to not trigger the implicit+lifting warning in derived code. (See #20688) -} @@ -1640,15 +1643,18 @@ gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag) where lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)- (map (pats_etc mk_exp) data_cons)+ (map (pats_etc mk_exp mk_usplice liftName) data_cons) liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)- (map (pats_etc mk_texp) data_cons)+ (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons) mk_exp = ExpBr noExtField mk_texp = TExpBr noExtField++ mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice+ mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice data_cons = getPossibleDataCons tycon tycon_args - pats_etc mk_bracket data_con+ pats_etc mk_bracket mk_splice lift_name data_con = ([con_pat], lift_Expr) where con_pat = nlConVarPat data_con_RDR as_needed@@ -1657,7 +1663,13 @@ as_needed = take con_arity as_RDRs lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body)) br_body = nlHsApps (Exact (dataConName data_con))- (map nlHsVar as_needed)+ (map lift_var as_needed)++ lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)+ lift_var x = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x))))++ mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)+ mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x] {- ************************************************************************
compiler/GHC/Tc/Errors.hs view
@@ -53,6 +53,7 @@ import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error+import GHC.Types.Unique.Set ( nonDetEltsUniqSet ) import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Misc import GHC.Data.FastString@@ -2358,6 +2359,17 @@ -- but we really only want to report the latter elim_superclasses cts = mkMinimalBySCs ctPred cts +-- [Note: mk_dict_err]+-- ~~~~~~~~~~~~~~~~~~~+-- Different dictionary error messages are reported depending on the number of+-- matches and unifiers:+--+-- - No matches, regardless of unifiers: report "No instance for ...".+-- - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",+-- and show the matching and unifying instances.+-- - One match, one or more unifiers: report "Overlapping instances for", show the+-- matching and unifying instances, and say "The choice depends on the instantion of ...,+-- and the result of evaluating ...". mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) -> TcM (ReportErrCtxt, SDoc) -- Report an overlap error if this class constraint results@@ -2523,12 +2535,24 @@ , nest 2 (vcat (pp_givens useful_givens))] , ppWhen (isSingleton matches) $- parens (vcat [ text "The choice depends on the instantiation of" <+>- quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))+ parens (vcat [ ppUnless (null tyCoVars) $+ text "The choice depends on the instantiation of" <+>+ quotes (pprWithCommas ppr tyCoVars)+ , ppUnless (null famTyCons) $+ if (null tyCoVars)+ then+ text "The choice depends on the result of evaluating" <+>+ quotes (pprWithCommas ppr famTyCons)+ else+ text "and the result of evaluating" <+>+ quotes (pprWithCommas ppr famTyCons) , ppWhen (null (matching_givens)) $ vcat [ text "To pick the first instance above, use IncoherentInstances" , text "when compiling the other instance declarations"] ])]+ where+ tyCoVars = tyCoVarsOfTypesList tys+ famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys matching_givens = mapMaybe matchable useful_givens
compiler/GHC/Tc/Gen/App.hs view
@@ -157,17 +157,18 @@ "application chain"? See Fig 2, of the QL paper: "A quick look at impredicativity" (ICFP'20). Here's the syntax: -app :: head- | app expr -- HsApp: ordinary application- | app @type -- HsTypeApp: VTA- | expr `head` expr -- OpApp: infix applications- | ( app ) -- HsPar: parens- | {-# PRAGMA #-} app -- HsPragE: pragmas+app ::= head+ | app expr -- HsApp: ordinary application+ | app @type -- HsTypeApp: VTA+ | expr `head` expr -- OpApp: infix applications+ | ( app ) -- HsPar: parens+ | {-# PRAGMA #-} app -- HsPragE: pragmas head ::= f -- HsVar: variables | fld -- HsRecFld: record field selectors | (expr :: ty) -- ExprWithTySig: expr with user type sig | lit -- HsOverLit: overloaded literals+ | $([| head |]) -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices | other_expr -- Other expressions When tcExpr sees something that starts an application chain (namely,@@ -185,7 +186,7 @@ we can't get a polytype from them. Left and right sections (e.g. (x +) and (+ x)) are not yet supported.-Probably left sections (x +) would be esay to add, since x is the+Probably left sections (x +) would be easy to add, since x is the first arg of (+); but right sections are not so easy. For symmetry reasons I've left both unchanged, in GHC.Tc.Gen.Expr. @@ -196,6 +197,16 @@ Clearly this should work! But it will /only/ work because if we instantiate that (forall b. b) impredicatively! And that only happens in tcApp.++We also wish to typecheck application chains with untyped Template Haskell+splices in the head, such as this example from #21038:+ data Foo = MkFoo (forall a. a -> a)+ f = $([| MkFoo |]) $ \x -> x+This should typecheck just as if the TH splice was never in the way—that is,+just as if the user had written `MkFoo $ \x -> x`. We could conceivably have+a case for typed TH expression splices too, but it wouldn't be useful in+practice, since the types of typed TH expressions aren't allowed to have+polymorphic types, such as the type of MkFoo. Note [tcApp: typechecking applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Gen/Bind.hs view
@@ -794,6 +794,9 @@ -- This type is just going into tcSubType, -- so Inferred vs. Specified doesn't matter + ; traceTc "mkExport" (vcat [ ppr poly_id <+> dcolon <+> ppr poly_ty+ , ppr sel_poly_ty ])+ ; wrap <- if sel_poly_ty `eqType` poly_ty -- NB: eqType ignores visibility then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType
compiler/GHC/Tc/Gen/Head.hs view
@@ -418,6 +418,8 @@ ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $ Just <$> tcExprWithSig e hs_ty HsOverLit _ lit -> Just <$> tcInferOverLit lit+ HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))+ -> tcInferAppHead_maybe e args mb_res_ty _ -> return Nothing add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1739,8 +1739,23 @@ The absence of this caused #14174 and #14520. -The calls to mkAppTyM is the other place we are very careful.+The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM]. +Wrinkle around FunTy:+Note that the PKTI does *not* guarantee anything about the shape of FunTys.+Specifically, when we have (FunTy vis mult arg res), it should be the case+that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we+might not have this. Example: if the user writes (a -> b), then we might+invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1+(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).+However, when we build the FunTy, we might not have zonked `a`, and so the+FunTy will be built without being able to purely extract the RuntimeReps.++Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,+we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*+split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]+in GHC.Tc.Solver.Canonical.+ Note [mkAppTyM] ~~~~~~~~~~~~~~~ mkAppTyM is trying to guarantee the Purely Kinded Type Invariant@@ -3539,7 +3554,7 @@ etaExpandAlgTyCon tc_bndrs kind = do { loc <- getSrcSpanM ; uniqs <- newUniqueSupply- ; rdr_env <- getLocalRdrEnv+ ; !rdr_env <- getLocalRdrEnv ; let new_occs = [ occ | str <- allNameStrings , let occ = mkOccName tvName str@@ -3561,11 +3576,12 @@ -> go loc occs' uniqs' subst' (tcb : acc) kind' where arg' = substTy subst (scaledThing arg)- tv = mkTyVar (mkInternalName uniq occ loc) arg'+ -- Force the occ before making the TyVar as otherwise it retains the TcLclEnv+ tv = occ `seq` mkTyVar (mkInternalName uniq occ loc) arg' subst' = extendTCvInScope subst tv tcb = Bndr tv (AnonTCB af) (uniq:uniqs') = uniqs- (occ:occs') = occs+ (!occ:occs') = occs Just (Named (Bndr tv vis), kind') -> go loc occs uniqs subst' (tcb : acc) kind'
compiler/GHC/Tc/Gen/Rule.hs view
@@ -134,7 +134,7 @@ ; (lhs_evs, residual_lhs_wanted) <- simplifyRule name tc_lvl lhs_wanted rhs_wanted - -- SimplfyRule Plan, step 4+ -- SimplifyRule Plan, step 4 -- Now figure out what to quantify over -- c.f. GHC.Tc.Solver.simplifyInfer -- We quantify over any tyvars free in *either* the rule@@ -306,8 +306,9 @@ * Step 0: typecheck the LHS and RHS to get constraints from each -* Step 1: Simplify the LHS and RHS constraints all together in one bag- We do this to discover all unification equalities+* Step 1: Simplify the LHS and RHS constraints all together in one bag,+ but /discarding/ the simplified constraints. We do this only+ to discover all unification equalities. * Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take advantage of those unifications
compiler/GHC/Tc/Solver.hs view
@@ -54,6 +54,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Core.Type+import GHC.Core.Ppr import GHC.Builtin.Types ( liftedRepTy, manyDataConTy ) import GHC.Core.Unify ( tcMatchTyKi ) import GHC.Utils.Misc@@ -672,7 +673,6 @@ Note [Safe Haskell Overlapping Instances Implementation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- How is this implemented? It's complicated! So we'll step through it all: 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where@@ -1011,7 +1011,7 @@ <- setTcLevel rhs_tclvl $ runTcSWithEvBinds ev_binds_var $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)- -- psig_evs : see Note [Add signature contexts as givens]+ -- psig_evs : see Note [Add signature contexts as wanteds] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over@@ -1047,9 +1047,9 @@ -- All done! ; traceTc "} simplifyInfer/produced residual implication for quantification" $ vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates- , text "psig_theta =" <+> ppr psig_theta- , text "bound_theta =" <+> ppr bound_theta- , text "qtvs =" <+> ppr qtvs+ , text "psig_theta =" <+> ppr psig_theta+ , text "bound_theta =" <+> pprCoreBinders bound_theta_vars+ , text "qtvs =" <+> ppr qtvs , text "definite_error =" <+> ppr definite_error ] ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }@@ -1107,7 +1107,14 @@ , let ev = ctEvidence ct ] findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType+-- Given a partial type signature f :: (C a, D a, _) => blah+-- and the inferred constraints (X a, D a, Y a, C a)+-- compute the difference, which is what will fill in the "_" underscore,+-- In this case the diff is (X a, Y a). findInferredDiff annotated_theta inferred_theta+ | null annotated_theta -- Short cut the common case when the user didn't+ = return inferred_theta -- write any constraints in the partial signature+ | otherwise = pushTcLevelM_ $ do { lcl_env <- TcM.getLclEnv ; given_ids <- mapM TcM.newEvVar annotated_theta@@ -1184,8 +1191,25 @@ fundeps Solution: in simplifyInfer, we add the constraints from the signature-as extra Wanteds+as extra Wanteds. +Why Wanteds? Wouldn't it be neater to treat them as Givens? Alas+that would mess up (GivenInv) in Note [TcLevel invariants]. Consider+ f :: (Eq a, _) => blah1+ f = ....g...+ g :: (Eq b, _) => blah2+ g = ...f...++Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with+TyVarTvs inside. Ultimately a[tv] := b[tv], but only when we've solved+all those constraints. And both have level 1, so we can't put them as+Givens when solving at level 1.++Best to treat them as Wanteds.++But see also #20076, which would be solved if they were Givens.++ ************************************************************************ * * Quantification@@ -1265,18 +1289,24 @@ -- into quantified skolems, so we have to zonk again ; candidates <- TcM.zonkTcTypes candidates ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)- ; let quantifiable_candidates- = pickQuantifiablePreds (mkVarSet qtvs) candidates+ ; let min_theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses]+ pickQuantifiablePreds (mkVarSet qtvs) candidates - theta = mkMinimalBySCs id $ -- See Note [Minimize by Superclasses]- psig_theta ++ quantifiable_candidates- -- NB: add psig_theta back in here, even though it's already- -- part of candidates, because we always want to quantify over- -- psig_theta, and pickQuantifiableCandidates might have- -- dropped some e.g. CallStack constraints. c.f #14658- -- equalities (a ~ Bool)- -- Remember, this is the theta for the residual constraint+ min_psig_theta = mkMinimalBySCs id psig_theta + -- Add psig_theta back in here, even though it's already+ -- part of candidates, because we always want to quantify over+ -- psig_theta, and pickQuantifiableCandidates might have+ -- dropped some e.g. CallStack constraints. c.f #14658+ -- equalities (a ~ Bool)+ -- It's helpful to use the same "find difference" algorithm here as+ -- we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921)+ -- See Note [Constraints in partial type signatures]+ ; theta <- if null psig_theta+ then return min_theta -- Fast path for the non-partial-sig case+ else do { diff <- findInferredDiff min_psig_theta min_theta+ ; return (min_psig_theta ++ diff) }+ ; traceTc "decideQuantification" (vcat [ text "infer_mode:" <+> ppr infer_mode , text "candidates:" <+> ppr candidates@@ -1287,7 +1317,39 @@ , text "theta:" <+> ppr theta ]) ; return (qtvs, theta, co_vars) } -------------------+{- Note [Constraints in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a partial type signature+ f :: (Eq a, C a, _) => blah++We will ultimately quantify f over (Eq a, C a, <diff>), where++ * <diff> is the result of+ findInferredDiff (Eq a, C a) <quant-theta>+ in GHC.Tc.Gen.Bind.chooseInferredQuantifiers++ * <quant-theta> is the theta returned right here,+ by decideQuantification++At least for single functions we would like to quantify f over+precisely the same theta as <quant-theta>, so that we get to take+the short-cut path in GHC.Tc.Gen.Bind.mkExport, and avoid calling+tcSubTypeSigma for impedence matching. Why avoid? Because it falls+over for ambiguous types (#20921).++We can get precisely the same theta by using the same algorithm,+findInferredDiff.++All of this goes wrong if we have (a) mutual recursion, (b) mutiple+partial type signatures, (c) with different constraints, and (d)+ambiguous types. Something like+ f :: forall a. Eq a => F a -> _+ f x = (undefined :: a) == g x undefined+ g :: forall b. Show b => F b -> _ -> b+ g x y = let _ = (f y, show x) in x+But that's a battle for another day.+-}+ decideMonoTyVars :: InferMode -> [(Name,TcType)] -> [TcIdSigInst]
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -904,7 +904,6 @@ It is conceivable to do a better job at tracking whether or not a type is rewritten, but this is left as future work. (Mar '15) - Note [Decomposing FunTy] ~~~~~~~~~~~~~~~~~~~~~~~~ can_eq_nc' may attempt to decompose a FunTy that is un-zonked. This@@ -1281,8 +1280,8 @@ split2 = tcSplitFunTy_maybe ty2 go ty1 ty2- | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1- , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2+ | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1+ , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2 = if tc1 == tc2 && tys1 `equalLength` tys2 -- Crucial to check for equal-length args, because -- we cannot assume that the two args to 'go' have
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -33,11 +33,12 @@ import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Exts (oneShot)+import Data.Bifunctor import Control.Monad import GHC.Utils.Monad ( zipWith3M ) import Data.List.NonEmpty ( NonEmpty(..) )--import Control.Arrow ( first )+import Control.Applicative (liftA3)+import GHC.Builtin.Types.Prim (tYPETyCon) {- ************************************************************************@@ -474,28 +475,28 @@ -- a Derived rewriting a Derived. The solution would be to generate evidence for -- Deriveds, thus avoiding this whole noBogusCoercions idea. See also -- Note [No derived kind equalities]- = do { rewritten_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)+ = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True) roles tys ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) } where- {-# INLINE fl #-}- fl :: Bool -- must we ensure to produce a real coercion here?- -- see comment at top of function+ {-# INLINE rw #-}+ rw :: Bool -- must we ensure to produce a real coercion here?+ -- see comment at top of function -> Role -> Type -> RewriteM (Xi, Coercion)- fl True r ty = noBogusCoercions $ fl1 r ty- fl False r ty = fl1 r ty+ rw True r ty = noBogusCoercions $ rw1 r ty+ rw False r ty = rw1 r ty - {-# INLINE fl1 #-}- fl1 :: Role -> Type -> RewriteM (Xi, Coercion)- fl1 Nominal ty+ {-# INLINE rw1 #-}+ rw1 :: Role -> Type -> RewriteM (Xi, Coercion)+ rw1 Nominal ty = setEqRel NomEq $ rewrite_one ty - fl1 Representational ty+ rw1 Representational ty = setEqRel ReprEq $ rewrite_one ty - fl1 Phantom ty+ rw1 Phantom ty -- See Note [Phantoms in the rewriter] = do { ty <- liftTcS $ zonkTcType ty ; return (ty, mkReflCo Phantom ty) }@@ -534,13 +535,47 @@ | otherwise = rewrite_ty_con_app tc tys -rewrite_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })- = do { (xi1,co1) <- rewrite_one ty1- ; (xi2,co2) <- rewrite_one ty2- ; (xi3,co3) <- setEqRel NomEq $ rewrite_one mult+rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })+ = do { (arg_xi,arg_co) <- rewrite_one ty1+ ; (res_xi,res_co) <- rewrite_one ty2++ -- Important: look at the *reduced* type, so that any unzonked variables+ -- in kinds are gone and the getRuntimeRep succeeds.+ -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.+ ; let arg_rep = getRuntimeRep arg_xi+ res_rep = getRuntimeRep res_xi++ ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $+ liftA3 (,,) (rewrite_one mult)+ (rewrite_one arg_rep)+ (rewrite_one res_rep) ; role <- getRole- ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 }- , mkFunCo role co3 co1 co2) }++ ; let arg_rep_co = mkSymCo (snd arg_rep_redn)+ -- :: arg_rep ~ arg_rep_xi+ arg_ki_co = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]+ -- :: TYPE arg_rep ~ TYPE arg_rep_xi+ casted_arg_redn =+ ( mkCastTy arg_xi arg_ki_co+ , mkCoherenceLeftCo role arg_xi arg_ki_co arg_co+ )+ -- :: ty1 ~> arg_xi |> arg_ki_co++ res_ki_co = mkTyConAppCo Nominal tYPETyCon [mkSymCo $ snd res_rep_redn]+ casted_res_redn =+ ( mkCastTy res_xi res_ki_co+ , mkCoherenceLeftCo role res_xi res_ki_co res_co+ )++ -- We must rewrite the representations, because that's what would+ -- be done if we used TyConApp instead of FunTy. These rewritten+ -- representations are seen only in casts of the arg and res, below.+ -- Forgetting this caused #19677.+ ; return+ ( mkFunTy vis (fst w_redn) (fst casted_arg_redn) (fst casted_res_redn)+ , mkFunCo role (snd w_redn) (snd casted_arg_redn) (snd casted_res_redn)+ )+ } rewrite_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -153,7 +153,7 @@ go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyNameEnv- go_prov CorePrepProv = emptyNameEnv+ go_prov (CorePrepProv _) = emptyNameEnv go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc | otherwise = emptyNameEnv
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -542,7 +542,8 @@ -- See Note [Skolemising type variables] tcInstSkolTyVarsPushLevel overlappable subst tvs = do { tc_lvl <- getTcLevel- ; let pushed_lvl = pushTcLevel tc_lvl+ -- Do not retain the whole TcLclEnv+ ; let !pushed_lvl = pushTcLevel tc_lvl ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } tcInstSkolTyVarsAt :: TcLevel -> Bool
compiler/GHC/Tc/Utils/Monad.hs view
@@ -698,8 +698,7 @@ updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () -- Returns ()-updTcRef ref fn = liftIO $ do { old <- readIORef ref- ; writeIORef ref (fn old) }+updTcRef ref fn = liftIO $ modifyIORef' ref fn {- ************************************************************************
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1531,7 +1531,7 @@ go_prov dv (PhantomProv co) = go_co dv co go_prov dv (ProofIrrelProv co) = go_co dv co go_prov dv (PluginProv _) = return dv- go_prov dv CorePrepProv = return dv+ go_prov dv (CorePrepProv _) = return dv go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs go_cv dv@(DV { dv_cvs = cvs }) cv
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 9.2.1.20220109+version: 9.2.2.20220307 license: BSD3 license-file: LICENSE category: Development@@ -79,7 +79,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 9.2.1.20220109+ ghc-lib-parser == 9.2.2.20220307 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -626,7 +626,6 @@ GHC.Iface.Rename GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable- GHC.Iface.UpdateIdInfos GHC.IfaceToCore GHC.Linker GHC.Linker.Dynamic
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -206,7 +206,7 @@ , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n The ByteArray\\# and the memory region at Addr\\# must fully contain the\n specified ranges, but this is not checked. The Addr\\# must not point into the\n ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n either.") , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n pinned), but this is not checked either.") , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n contain the specified ranges, but this is not checked. The Addr\\# must not\n point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n but this is not checked either.")- , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len]@ of\n the @MutableByteArray#@ to the byte @c@.")+ , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len)@ of\n the @MutableByteArray#@ to the byte @c@.") , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n index is assumed to be in bounds. Implies a full memory barrier.") , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n the new value, perform an atomic compare and swap i.e. write the new\n value if the current value matches the provided old value. Returns\n the value of the element before the operation. Implies a full memory\n barrier.")
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -97,7 +97,7 @@ /* Define to 1 if you have the <bfd.h> header file. */ /* #undef HAVE_BFD_H */ -/* Does GCC support __atomic primitives? */+/* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 /* Define to 1 if you have the `clock_gettime' function. */@@ -113,6 +113,10 @@ don't. */ #define HAVE_DECL_CTIME_R 1 +/* Define to 1 if you have the declaration of `environ', and to 0 if you+ don't. */+#define HAVE_DECL_ENVIRON 0+ /* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */@@ -374,6 +378,9 @@ /* Define to 1 if C symbols have a leading underscore added by the compiler. */ #define LEADING_UNDERSCORE 1++/* Define to 1 if we need -latomic. */+#define NEED_ATOMIC_LIB 0 /* Define 1 if we need to link code using pthreads with -lpthread */ #define NEED_PTHREAD_LIB 0
ghc-lib/stage0/lib/settings view
@@ -40,7 +40,6 @@ ,("LLVM llc command", "llc") ,("LLVM opt command", "opt") ,("LLVM clang command", "clang")-,("BigNum backend", "native") ,("Use interpreter", "YES") ,("Support SMP", "YES") ,("RTS ways", "v thr")