diff --git a/GHC/Cmm/CLabel.hs b/GHC/Cmm/CLabel.hs --- a/GHC/Cmm/CLabel.hs +++ b/GHC/Cmm/CLabel.hs @@ -62,6 +62,7 @@ mkSMAP_FROZEN_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, + mkOutOfBoundsAccessLabel, mkArrWords_infoLabel, mkSRTInfoLabel, @@ -599,7 +600,8 @@ mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, - mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel + mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, + mkOutOfBoundsAccessLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData @@ -617,6 +619,7 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry +mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction mkSRTInfoLabel :: Int -> CLabel mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) lbl CmmInfo diff --git a/GHC/Cmm/CommonBlockElim.hs b/GHC/Cmm/CommonBlockElim.hs --- a/GHC/Cmm/CommonBlockElim.hs +++ b/GHC/Cmm/CommonBlockElim.hs @@ -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 diff --git a/GHC/Cmm/DebugBlock.hs b/GHC/Cmm/DebugBlock.hs --- a/GHC/Cmm/DebugBlock.hs +++ b/GHC/Cmm/DebugBlock.hs @@ -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) diff --git a/GHC/Cmm/Expr.hs b/GHC/Cmm/Expr.hs --- a/GHC/Cmm/Expr.hs +++ b/GHC/Cmm/Expr.hs @@ -9,6 +9,7 @@ ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr , CmmReg(..), cmmRegType, cmmRegWidth , CmmLit(..), cmmLitType + , AlignmentSpec(..) , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType , spReg, hpReg, spLimReg, hpLimReg, nodeReg @@ -53,12 +54,13 @@ ----------------------------------------------------------------------------- data CmmExpr - = CmmLit !CmmLit -- Literal - | CmmLoad !CmmExpr !CmmType -- Read memory location + = CmmLit !CmmLit -- Literal + | CmmLoad !CmmExpr !CmmType !AlignmentSpec + -- Read memory location | CmmReg !CmmReg -- Contents of register | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.) | CmmStackSlot Area {-# UNPACK #-} !Int - -- addressing expression of a stack slot + -- Addressing expression of a stack slot -- See Note [CmmStackSlot aliasing] | CmmRegOff !CmmReg !Int -- CmmRegOff reg i @@ -69,13 +71,16 @@ instance Eq CmmExpr where -- Equality ignores the types CmmLit l1 == CmmLit l2 = l1==l2 - CmmLoad e1 _ == CmmLoad e2 _ = e1==e2 + CmmLoad e1 _ _ == CmmLoad e2 _ _ = e1==e2 CmmReg r1 == CmmReg r2 = r1==r2 CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2 CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 _e1 == _e2 = False +data AlignmentSpec = NaturallyAligned | Unaligned + deriving (Eq, Ord, Show) + data CmmReg = CmmLocal {-# UNPACK #-} !LocalReg | CmmGlobal GlobalReg @@ -225,7 +230,7 @@ cmmExprType :: Platform -> CmmExpr -> CmmType cmmExprType platform = \case (CmmLit lit) -> cmmLitType platform lit - (CmmLoad _ rep) -> rep + (CmmLoad _ rep _) -> rep (CmmReg reg) -> cmmRegType platform reg (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) (CmmRegOff reg _) -> cmmRegType platform reg @@ -385,7 +390,7 @@ {-# INLINEABLE foldRegsUsed #-} foldRegsUsed platform f !z e = expr z e where expr z (CmmLit _) = z - expr z (CmmLoad addr _) = foldRegsUsed platform f z addr + expr z (CmmLoad addr _ _) = foldRegsUsed platform f z addr expr z (CmmReg r) = foldRegsUsed platform f z r expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs expr z (CmmRegOff r _) = foldRegsUsed platform f z r diff --git a/GHC/Cmm/Graph.hs b/GHC/Cmm/Graph.hs --- a/GHC/Cmm/Graph.hs +++ b/GHC/Cmm/Graph.hs @@ -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 diff --git a/GHC/Cmm/Info.hs b/GHC/Cmm/Info.hs --- a/GHC/Cmm/Info.hs +++ b/GHC/Cmm/Info.hs @@ -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 diff --git a/GHC/Cmm/LayoutStack.hs b/GHC/Cmm/LayoutStack.hs --- a/GHC/Cmm/LayoutStack.hs +++ b/GHC/Cmm/LayoutStack.hs @@ -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) diff --git a/GHC/Cmm/Lint.hs b/GHC/Cmm/Lint.hs --- a/GHC/Cmm/Lint.hs +++ b/GHC/Cmm/Lint.hs @@ -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 () diff --git a/GHC/Cmm/MachOp.hs b/GHC/Cmm/MachOp.hs --- a/GHC/Cmm/MachOp.hs +++ b/GHC/Cmm/MachOp.hs @@ -102,6 +102,8 @@ | MO_Or Width | MO_Xor Width | MO_Not Width + + -- Shifts. The shift amount must be in [0,widthInBits). | MO_Shl Width | MO_U_Shr Width -- unsigned shift right | MO_S_Shr Width -- signed shift right diff --git a/GHC/Cmm/Node.hs b/GHC/Cmm/Node.hs --- a/GHC/Cmm/Node.hs +++ b/GHC/Cmm/Node.hs @@ -74,7 +74,7 @@ CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O -- Assign to register - CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O + CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> CmmNode O O -- Assign to memory location. Size is -- given by cmmExprType of the rhs. @@ -321,7 +321,7 @@ {-# INLINEABLE foldRegsUsed #-} foldRegsUsed platform f !z n = case n of CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval + CmmStore addr rval _ -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args CmmCondBranch expr _ _ _ -> fold f z expr CmmSwitch expr _ -> fold f z expr @@ -336,7 +336,7 @@ {-# INLINEABLE foldRegsUsed #-} foldRegsUsed platform f !z n = case n of CmmAssign _ expr -> fold f z expr - CmmStore addr rval -> fold f (fold f z addr) rval + CmmStore addr rval _ -> fold f (fold f z addr) rval CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args CmmCondBranch expr _ _ _ -> fold f z expr CmmSwitch expr _ -> fold f z expr @@ -464,9 +464,9 @@ -- Take a transformer on expressions and apply it recursively. -- (wrapRecExp f e) first recursively applies itself to sub-expressions of e -- then uses f to rewrite the resulting expression -wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) -wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) -wrapRecExp f e = f e +wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) +wrapRecExp f (CmmLoad addr ty align) = f (CmmLoad (wrapRecExp f addr) ty align) +wrapRecExp f e = f e mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x mapExp _ f@(CmmEntry{}) = f @@ -474,7 +474,7 @@ mapExp _ m@(CmmTick _) = m mapExp f (CmmUnwind regs) = CmmUnwind (map (fmap (fmap f)) regs) mapExp f (CmmAssign r e) = CmmAssign r (f e) -mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) +mapExp f (CmmStore addr e align) = CmmStore (f addr) (f e) align mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) mapExp _ l@(CmmBranch _) = l mapExp f (CmmCondBranch e ti fi l) = CmmCondBranch (f e) ti fi l @@ -495,9 +495,9 @@ wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) -- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e -- then gives f a chance to rewrite the resulting expression -wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) -wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) -wrapRecExpM f e = f e +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty align) = maybe (f n) (\addr' -> f $ CmmLoad addr' ty align) (wrapRecExpM f addr) +wrapRecExpM f e = f e mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) mapExpM _ (CmmEntry{}) = Nothing @@ -505,7 +505,7 @@ mapExpM _ (CmmTick _) = Nothing mapExpM f (CmmUnwind regs) = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e -mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] +mapExpM f (CmmStore addr e align) = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, e] mapExpM _ (CmmBranch _) = Nothing mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e @@ -548,9 +548,9 @@ -- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad -- itself, delegating all the other CmmExpr forms to 'f'. wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z -wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es -wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) -wrapRecExpf f e z = f e z +wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es +wrapRecExpf f e@(CmmLoad addr _ _) z = wrapRecExpf f addr (f e z) +wrapRecExpf f e z = f e z foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z foldExp _ (CmmEntry {}) z = z @@ -558,7 +558,7 @@ foldExp _ (CmmTick {}) z = z foldExp f (CmmUnwind xs) z = foldr (maybe id f) z (map snd xs) foldExp f (CmmAssign _ e) z = f e z -foldExp f (CmmStore addr e) z = f addr $ f e z +foldExp f (CmmStore addr e _) z = f addr $ f e z foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as foldExp _ (CmmBranch _) z = z foldExp f (CmmCondBranch e _ _ _) z = f e z diff --git a/GHC/Cmm/Opt.hs b/GHC/Cmm/Opt.hs --- a/GHC/Cmm/Opt.hs +++ b/GHC/Cmm/Opt.hs @@ -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 diff --git a/GHC/Cmm/Parser.y b/GHC/Cmm/Parser.y --- a/GHC/Cmm/Parser.y +++ b/GHC/Cmm/Parser.y @@ -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 () diff --git a/GHC/Cmm/Ppr.hs b/GHC/Cmm/Ppr.hs --- a/GHC/Cmm/Ppr.hs +++ b/GHC/Cmm/Ppr.hs @@ -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]; diff --git a/GHC/Cmm/Ppr/Expr.hs b/GHC/Cmm/Ppr/Expr.hs --- a/GHC/Cmm/Ppr/Expr.hs +++ b/GHC/Cmm/Ppr/Expr.hs @@ -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) diff --git a/GHC/Cmm/Sink.hs b/GHC/Cmm/Sink.hs --- a/GHC/Cmm/Sink.hs +++ b/GHC/Cmm/Sink.hs @@ -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 = diff --git a/GHC/Cmm/Type.hs b/GHC/Cmm/Type.hs --- a/GHC/Cmm/Type.hs +++ b/GHC/Cmm/Type.hs @@ -181,16 +181,20 @@ -------- Common Widths ------------ + +-- | The width of the current platform's word size. wordWidth :: Platform -> Width wordWidth platform = case platformWordSize platform of PW4 -> W32 PW8 -> W64 +-- | The width of the current platform's half-word size. halfWordWidth :: Platform -> Width halfWordWidth platform = case platformWordSize platform of PW4 -> W16 PW8 -> W32 +-- | A bit-mask for the lower half-word of current platform. halfWordMask :: Platform -> Integer halfWordMask platform = case platformWordSize platform of PW4 -> 0xFFFF @@ -203,6 +207,7 @@ 8 -> W64 s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) +-- | A width in bits. widthInBits :: Width -> Int widthInBits W8 = 8 widthInBits W16 = 16 @@ -212,7 +217,9 @@ widthInBits W256 = 256 widthInBits W512 = 512 - +-- | A width in bytes. +-- +-- > widthFromBytes (widthInBytes w) === w widthInBytes :: Width -> Int widthInBytes W8 = 1 widthInBytes W16 = 2 @@ -223,6 +230,7 @@ widthInBytes W512 = 64 +-- | *Partial* A width from the number of bytes. widthFromBytes :: Int -> Width widthFromBytes 1 = W8 widthFromBytes 2 = W16 @@ -234,7 +242,7 @@ widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) --- log_2 of the width in bytes, useful for generating shifts. +-- | log_2 of the width in bytes, useful for generating shifts. widthInLog :: Width -> Int widthInLog W8 = 0 widthInLog W16 = 1 @@ -247,6 +255,20 @@ -- widening / narrowing +-- | Narrow a signed or unsigned value to the given width. The result will +-- reside in @[0, +2^width)@. +-- +-- >>> narrowU W8 256 == 256 +-- >>> narrowU W8 255 == 255 +-- >>> narrowU W8 128 == 128 +-- >>> narrowU W8 127 == 127 +-- >>> narrowU W8 0 == 0 +-- >>> narrowU W8 (-127) == 129 +-- >>> narrowU W8 (-128) == 128 +-- >>> narrowU W8 (-129) == 127 +-- >>> narrowU W8 (-255) == 1 +-- >>> narrowU W8 (-256) == 0 +-- narrowU :: Width -> Integer -> Integer narrowU W8 x = fromIntegral (fromIntegral x :: Word8) narrowU W16 x = fromIntegral (fromIntegral x :: Word16) @@ -254,6 +276,20 @@ narrowU W64 x = fromIntegral (fromIntegral x :: Word64) narrowU _ _ = panic "narrowTo" +-- | Narrow a signed value to the given width. The result will reside +-- in @[-2^(width-1), +2^(width-1))@. +-- +-- >>> narrowS W8 256 == 0 +-- >>> narrowS W8 255 == -1 +-- >>> narrowS W8 128 == -128 +-- >>> narrowS W8 127 == 127 +-- >>> narrowS W8 0 == 0 +-- >>> narrowS W8 (-127) == -127 +-- >>> narrowS W8 (-128) == -128 +-- >>> narrowS W8 (-129) == 127 +-- >>> narrowS W8 (-255) == 1 +-- >>> narrowS W8 (-256) == 0 +-- narrowS :: Width -> Integer -> Integer narrowS W8 x = fromIntegral (fromIntegral x :: Int8) narrowS W16 x = fromIntegral (fromIntegral x :: Int16) diff --git a/GHC/Cmm/Utils.hs b/GHC/Cmm/Utils.hs --- a/GHC/Cmm/Utils.hs +++ b/GHC/Cmm/Utils.hs @@ -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 diff --git a/GHC/CmmToAsm.hs b/GHC/CmmToAsm.hs --- a/GHC/CmmToAsm.hs +++ b/GHC/CmmToAsm.hs @@ -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 diff --git a/GHC/CmmToAsm/AArch64/CodeGen.hs b/GHC/CmmToAsm/AArch64/CodeGen.hs --- a/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -1,4 +1,5 @@ -{-# language GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE BinaryLiterals #-} @@ -11,9 +12,13 @@ where +#include "HsVersions.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 <- x -- compute x <- y -- x, x, x - (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 <- x + -- compute x <- y + -- x, x, x + (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 + => MO_Add - 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) diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -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 , , #0, #7 -- UXTH = UBFM , , #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 diff --git a/GHC/CmmToAsm/AArch64/Ppr.hs b/GHC/CmmToAsm/AArch64/Ppr.hs --- a/GHC/CmmToAsm/AArch64/Ppr.hs +++ b/GHC/CmmToAsm/AArch64/Ppr.hs @@ -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 diff --git a/GHC/CmmToAsm/PIC.hs b/GHC/CmmToAsm/PIC.hs --- a/GHC/CmmToAsm/PIC.hs +++ b/GHC/CmmToAsm/PIC.hs @@ -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: diff --git a/GHC/CmmToAsm/PPC/CodeGen.hs b/GHC/CmmToAsm/PPC/CodeGen.hs --- a/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/GHC/CmmToAsm/PPC/CodeGen.hs @@ -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)) diff --git a/GHC/CmmToAsm/SPARC/CodeGen.hs b/GHC/CmmToAsm/SPARC/CodeGen.hs --- a/GHC/CmmToAsm/SPARC/CodeGen.hs +++ b/GHC/CmmToAsm/SPARC/CodeGen.hs @@ -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 diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs --- a/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +++ b/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs @@ -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 diff --git a/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs b/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs --- a/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +++ b/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs @@ -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 diff --git a/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/GHC/CmmToAsm/X86/CodeGen.hs @@ -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) diff --git a/GHC/CmmToC.hs b/GHC/CmmToC.hs --- a/GHC/CmmToC.hs +++ b/GHC/CmmToC.hs @@ -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 diff --git a/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs --- a/GHC/CmmToLlvm/CodeGen.hs +++ b/GHC/CmmToLlvm/CodeGen.hs @@ -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 diff --git a/GHC/Core/Coercion.hs b/GHC/Core/Coercion.hs --- a/GHC/Core/Coercion.hs +++ b/GHC/Core/Coercion.hs @@ -35,7 +35,7 @@ mkPiCo, mkPiCos, mkCoCast, mkSymCo, mkTransCo, mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo, - mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo, mkForAllCo, mkForAllCos, mkHomoForAllCos, mkPhantomCo, mkHoleCo, mkUnivCo, mkSubCo, @@ -72,7 +72,9 @@ isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo, mkCoherenceRightMCo, - coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo, + coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo, + mkHomoForAllMCo, mkFunResMCo, mkPiMCos, checkReflexiveMCo, + isReflMCo, -- ** Coercion variables mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, @@ -311,6 +313,11 @@ coToMCo co | isReflCo co = MRefl | otherwise = MCo co +checkReflexiveMCo :: MCoercion -> MCoercion +checkReflexiveMCo MRefl = MRefl +checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl + | otherwise = MCo co + -- | Tests if this MCoercion is obviously generalized reflexive -- Guaranteed to work very quickly. isGReflMCo :: MCoercion -> Bool @@ -332,9 +339,13 @@ mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) mkTransMCoL :: MCoercion -> Coercion -> MCoercion -mkTransMCoL MRefl co2 = MCo co2 +mkTransMCoL MRefl co2 = coToMCo co2 mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2) +mkTransMCoR :: Coercion -> MCoercion -> MCoercion +mkTransMCoR co1 MRefl = coToMCo co1 +mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2) + -- | Get the reverse of an 'MCoercion' mkSymMCo :: MCoercion -> MCoercion mkSymMCo MRefl = MRefl @@ -345,6 +356,18 @@ mkCastTyMCo ty MRefl = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co +mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion +mkHomoForAllMCo _ MRefl = MRefl +mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co) + +mkPiMCos :: [Var] -> MCoercion -> MCoercion +mkPiMCos _ MRefl = MRefl +mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co) + +mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR +mkFunResMCo _ MRefl = MRefl +mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty co) + mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion mkGReflLeftMCo r ty MRefl = mkReflCo r ty mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co @@ -454,7 +477,7 @@ -> (TCvSubst,Kind) -- Rhs kind of coercion -> [Type] -- Arguments to that function -> ([CoercionN], Coercion) - -- Invariant: co :: subst1(k2) ~ subst2(k2) + -- Invariant: co :: subst1(k1) ~ subst2(k2) go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) | Just (a, t1) <- splitForAllTyCoVar_maybe k1 @@ -1053,18 +1076,18 @@ -> Coercion mkNthCo r n co = ASSERT2( good_call, bad_call_msg ) - go r n co + go n co where Pair ty1 ty2 = coercionKind co - go r 0 co + go 0 co | Just (ty, _) <- isReflCo_maybe co , Just (tv, _) <- splitForAllTyCoVar_maybe ty = -- works for both tyvar and covar ASSERT( r == Nominal ) mkNomReflCo (varType tv) - go r n co + go n co | Just (ty, r0) <- isReflCo_maybe co , let tc = tyConAppTyCon ty = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) @@ -1079,7 +1102,7 @@ | otherwise = False - go r 0 (ForAllCo _ kind_co _) + go 0 (ForAllCo _ kind_co _) = ASSERT( r == Nominal ) kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) @@ -1087,10 +1110,10 @@ -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) - go _ n (FunCo _ w arg res) + go n (FunCo _ w arg res) = mkNthCoFunCo n w arg res - go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n + go n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n , (vcat [ ppr tc , ppr arg_cos , ppr r0 @@ -1098,9 +1121,12 @@ , ppr r ]) ) arg_cos `getNth` n - go r n co = - NthCo r n co + go n (SymCo co) -- Recurse, hoping to get to a TyConAppCo or FunCo + = mkSymCo (go n co) + go n co + = NthCo r n co + -- Assertion checking bad_call_msg = vcat [ text "Coercion =" <+> ppr co , text "LHS ty =" <+> ppr ty1 @@ -1352,7 +1378,7 @@ | case prov of PhantomProv _ -> False -- should always be phantom ProofIrrelProv _ -> True -- it's always safe PluginProv _ -> False -- who knows? This choice is conservative. - CorePrepProv -> True + CorePrepProv _ -> True = Just $ UnivCo prov Nominal co1 co2 setNominalRole_maybe_helper _ = Nothing @@ -1456,10 +1482,10 @@ AxiomInstCo {} -> mkKindCo co AxiomRuleCo {} -> mkKindCo co - UnivCo (PhantomProv kco) _ _ _ -> kco + UnivCo (PhantomProv kco) _ _ _ -> kco UnivCo (ProofIrrelProv kco) _ _ _ -> kco - UnivCo (PluginProv _) _ _ _ -> mkKindCo co - UnivCo CorePrepProv _ _ _ -> mkKindCo co + UnivCo (PluginProv _) _ _ _ -> mkKindCo co + UnivCo (CorePrepProv _) _ _ _ -> mkKindCo co SymCo g -> mkSymCo (promoteCoercion g) @@ -1621,9 +1647,18 @@ -- want it to be r. It is only called in 'mkPiCos', which is -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for -- now (Aug 2018) v won't occur in co. - mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co - | otherwise = mkFunCo r (multToCo (varMult v)) (mkReflCo r (varType v)) co + mkFunResCo r scaled_ty co + | otherwise = mkFunResCo r scaled_ty co + where + scaled_ty = Scaled (varMult v) (varType v) +mkFunResCo :: Role -> Scaled Type -> Coercion -> Coercion +-- Given res_co :: res1 -> res2, +-- mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2) +-- Reflexive in the multiplicity argument +mkFunResCo role (Scaled mult arg_ty) res_co + = mkFunCo role (multToCo mult) (mkReflCo role arg_ty) res_co + -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 -- The first coercion might be lifted or unlifted; thus the ~? above -- Lifted and unlifted equalities take different numbers of arguments, @@ -1779,7 +1814,7 @@ -- -- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') -- --- then (a) @co : ty0 ~ ty'@. +-- then (a) @co : ty ~ ty'@. -- (b) ty' is not a newtype. -- -- The function returns @Nothing@ for non-@newtypes@, @@ -2283,7 +2318,7 @@ seqProv (PhantomProv co) = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _) = () -seqProv CorePrepProv = () +seqProv (CorePrepProv _) = () seqCos :: [Coercion] -> () seqCos [] = () diff --git a/GHC/Core/Coercion/Opt.hs b/GHC/Core/Coercion/Opt.hs --- a/GHC/Core/Coercion/Opt.hs +++ b/GHC/Core/Coercion/Opt.hs @@ -576,7 +576,7 @@ #endif ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco PluginProv _ -> prov - CorePrepProv -> prov + CorePrepProv _ -> prov ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] diff --git a/GHC/Core/FVs.hs b/GHC/Core/FVs.hs --- a/GHC/Core/FVs.hs +++ b/GHC/Core/FVs.hs @@ -404,7 +404,7 @@ orphNamesOfProv (PhantomProv co) = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _) = emptyNameSet -orphNamesOfProv CorePrepProv = emptyNameSet +orphNamesOfProv (CorePrepProv _) = emptyNameSet orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo diff --git a/GHC/Core/Lint.hs b/GHC/Core/Lint.hs --- a/GHC/Core/Lint.hs +++ b/GHC/Core/Lint.hs @@ -2117,13 +2117,15 @@ -- see #9122 for discussion of these checks checkTypes t1 t2 + | allow_ill_kinded_univ_co prov + = return () -- Skip kind checks + | otherwise = do { checkWarnL (not lev_poly1) (report "left-hand type is levity-polymorphic") ; checkWarnL (not lev_poly2) (report "right-hand type is levity-polymorphic") ; when (not (lev_poly1 || lev_poly2)) $ - do { checkWarnL (reps1 `equalLength` reps2 || - is_core_prep_prov prov) + do { checkWarnL (reps1 `equalLength` reps2) (report "between values with different # of reps") ; zipWithM_ validateCoercion reps1 reps2 }} where @@ -2139,8 +2141,8 @@ -- e.g (case error @Int "blah" of {}) :: Int# -- ==> (error @Int "blah") |> Unsafe Int Int# -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep - is_core_prep_prov CorePrepProv = True - is_core_prep_prov _ = False + allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind + allow_ill_kinded_univ_co _ = False validateCoercion :: PrimRep -> PrimRep -> LintM () validateCoercion rep1 rep2 @@ -2171,8 +2173,8 @@ ; check_kinds kco k1 k2 ; return (ProofIrrelProv kco') } - lint_prov _ _ prov@(PluginProv _) = return prov - lint_prov _ _ prov@CorePrepProv = return prov + lint_prov _ _ prov@(PluginProv _) = return prov + lint_prov _ _ prov@(CorePrepProv _) = return prov check_kinds kco k1 k2 = do { let Pair k1' k2' = coercionKind kco diff --git a/GHC/Core/Make.hs b/GHC/Core/Make.hs --- a/GHC/Core/Make.hs +++ b/GHC/Core/Make.hs @@ -824,7 +824,9 @@ -- argument would require allocating a thunk. -- -- 4. it can't be CAFFY because that would mean making some non-CAFFY --- definitions that use unboxed sums CAFFY in unarise. +-- definitions that use unboxed sums CAFFY in unarise. We work around +-- this by declaring the absentSumFieldError as non-CAFfy, as described +-- in Note [Wired-in exceptions are not CAFfy]. -- -- Getting this wrong causes hard-to-debug runtime issues, see #15038. -- @@ -858,6 +860,21 @@ -- error. That's why it is OK for it to be un-catchable. -- +-- Note [Wired-in exceptions are not CAFfy] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- mkExceptionId claims that all exceptions are not CAFfy, despite the fact +-- that their closures' code may in fact contain CAF references. We get away +-- with this lie because the RTS ensures that all exception closures are +-- considered live by the GC by creating StablePtrs during initialization. +-- The lie is necessary to avoid unduly growing SRTs as these exceptions are +-- sufficiently common to warrant special treatment. +-- +-- At some point we could consider removing this optimisation as it is quite +-- fragile, but we do want to be careful to avoid adding undue cost. Unboxed +-- sums in particular are intended to be used in performance-critical contexts. +-- +-- See #15038, #21141. + absentSumFieldErrorName = mkWiredInIdName gHC_PRIM_PANIC @@ -899,6 +916,9 @@ rAISE_DIVZERO_ID = mkExceptionId raiseDivZeroName -- | Exception with type \"forall a. a\" +-- +-- Any exceptions added via this function needs to be added to +-- the RTS's initBuiltinGcRoots() function. mkExceptionId :: Name -> Id mkExceptionId name = mkVanillaGlobalWithInfo name @@ -906,7 +926,8 @@ (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botDiv `setCprInfo` mkCprSig 0 botCpr `setArityInfo` 0 - `setCafInfo` NoCafRefs) -- #15038 + `setCafInfo` NoCafRefs) + -- See Note [Wired-in exceptions are not CAFfy] mkRuntimeErrorId :: Name -> Id -- Error function diff --git a/GHC/Core/Map/Type.hs b/GHC/Core/Map/Type.hs --- a/GHC/Core/Map/Type.hs +++ b/GHC/Core/Map/Type.hs @@ -48,13 +48,13 @@ import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Data.Maybe import GHC.Utils.Panic import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Control.Monad ( (>=>) ) +import GHC.Data.Maybe -- NB: Be careful about RULES and type families (#5821). So we should make sure -- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) @@ -136,16 +136,17 @@ type TypeMapG = GenMap TypeMapX -- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the --- 'GenMap' optimization. +-- 'GenMap' optimization. See Note [Computing equality on types] in GHC.Core.Type. data TypeMapX a = TM { tm_var :: VarMap a - , tm_app :: TypeMapG (TypeMapG a) + , tm_app :: TypeMapG (TypeMapG a) -- Note [Equality on AppTys] in GHC.Core.Type , tm_tycon :: DNameEnv a -- only InvisArg arrows here , tm_funty :: TypeMapG (TypeMapG (TypeMapG a)) -- keyed on the argument, result rep, and result -- constraints are never linear-restricted and are always lifted + -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr , tm_tylit :: TyLitMap a diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -1285,6 +1285,7 @@ -- etaExpand arity e = res -- Then 'res' has at least 'arity' lambdas at the top +-- possibly with a cast wrapped around the outside -- See Note [Eta expansion with ArityType] -- -- etaExpand deals with for-alls. For example: @@ -1292,33 +1293,43 @@ -- where E :: forall a. a -> a -- would return -- (/\b. \y::a -> E b y) --- --- It deals with coerces too, though they are now rare --- so perhaps the extra code isn't worth it eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr +eta_expand one_shots (Cast expr co) + = mkCast (eta_expand one_shots expr) co + eta_expand one_shots orig_expr - = go one_shots orig_expr + = go one_shots [] orig_expr where -- Strip off existing lambdas and casts before handing off to mkEtaWW + -- This is mainly to avoid spending time cloning binders and substituting + -- when there is actually nothing to do. It's slightly awkward to deal + -- with casts here, apart from the topmost one, and they are rare, so + -- if we find one we just hand off to mkEtaWW anyway -- Note [Eta expansion and SCCs] - go [] expr = expr - go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss body) - | otherwise = Lam v (go oss1 body) - go oss (Cast expr co) = Cast (go oss expr) co + go [] _ _ = orig_expr -- Already has the specified arity; no-op - go oss expr + go oss@(_:oss1) vs (Lam v body) + | isTyVar v = go oss (v:vs) body + | otherwise = go oss1 (v:vs) body + + go oss rev_vs expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, pprEtaInfos etas]) $ - retick $ etaInfoAbs etas (etaInfoApp in_scope' sexpr etas) + retick $ etaInfoAbs top_eis $ + etaInfoApp in_scope' sexpr eis where in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + (in_scope', eis@(EI eta_bndrs mco)) + = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr) + top_bndrs = reverse rev_vs + top_eis = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco) -- Find ticks behind type apps. -- See Note [Eta expansion and source notes] + -- I don't really understand this code SLPJ May 21 (expr', args) = collectArgs expr (ticks, expr'') = stripTicksTop tickishFloatable expr' - sexpr = foldl' App expr'' args + sexpr = mkApps expr'' args retick expr = foldr mkTick expr ticks {- ********************************************************************* @@ -1333,23 +1344,23 @@ Suppose we have (e :: ty) and we want to eta-expand it to arity N. This what eta_expand does. We do it in two steps: -1. mkEtaWW: from 'ty' and 'N' build a [EtaInfo] which describes +1. mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes the shape of the expansion necessary to expand to arity N. 2. Build the term \ v1..vn. e v1 .. vn where those abstractions and applications are described by - the same [EtaInfo]. Specifically we build the term + the same EtaInfo. Specifically we build the term etaInfoAbs etas (etaInfoApp in_scope e etas) - where etas :: [EtaInfo]# + where etas :: EtaInfo etaInfoAbs builds the lambdas etaInfoApp builds the applictions - Note that the /same/ [EtaInfo] drives both etaInfoAbs and etaInfoApp + Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp -To a first approximation [EtaInfo] is just [Var]. But +To a first approximation EtaInfo is just [Var]. But casts complicate the question. If we have newtype N a = MkN (S -> a) and @@ -1370,7 +1381,7 @@ This matters a lot in etaEInfoApp, where we * Do beta-reduction on the fly -* Use getARg_mabye to get a cast out of the way, +* Use getArg_maybe to get a cast out of the way, so that we can do beta reduction Together this makes a big difference. Consider when e is case x of @@ -1388,88 +1399,17 @@ -} -------------- -data EtaInfo -- Abstraction Application - = EtaVar Var -- /\a. [] [] a - -- (\x. []) [] x - | EtaCo CoercionR -- [] |> sym co [] |> co +data EtaInfo = EI [Var] MCoercionR -instance Outputable EtaInfo where - ppr (EtaVar v) = text "EtaVar" <+> ppr v <+> dcolon <+> ppr (idType v) - ppr (EtaCo co) = text "EtaCo" <+> hang (ppr co) 2 (dcolon <+> ppr (coercionType co)) +-- EI bs co +-- Abstraction: (\b1 b2 .. bn. []) |> sym co +-- Application: ([] |> co) b1 b2 .. bn +-- +-- e :: T co :: T ~ (t1 -> t2 -> .. -> tn -> tr) +-- e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co --- Used in debug-printing --- pprEtaInfos :: [EtaInfo] -> SDoc --- pprEtaInfos eis = brackets $ vcat $ punctuate comma $ map ppr eis -pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] --- Puts a EtaCo on the front of a [EtaInfo], but combining --- with an existing EtaCo if possible --- A minor improvement -pushCoercion co1 (EtaCo co2 : eis) - | isReflCo co = eis - | otherwise = EtaCo co : eis - where - co = co1 `mkTransCo` co2 - -pushCoercion co eis - = EtaCo co : eis - -getArg_maybe :: [EtaInfo] -> Maybe (CoreArg, [EtaInfo]) --- Get an argument to the front of the [EtaInfo], if possible, --- by pushing any EtaCo through the argument -getArg_maybe eis = go MRefl eis - where - go :: MCoercion -> [EtaInfo] -> Maybe (CoreArg, [EtaInfo]) - go _ [] = Nothing - go mco (EtaCo co2 : eis) = go (mkTransMCoL mco co2) eis - go MRefl (EtaVar v : eis) = Just (varToCoreExpr v, eis) - go (MCo co) (EtaVar v : eis) - | Just (arg, mco) <- pushCoArg co (varToCoreExpr v) - = case mco of - MRefl -> Just (arg, eis) - MCo co -> Just (arg, pushCoercion co eis) - | otherwise - = Nothing - -mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr -mkCastMCo e MRefl = e -mkCastMCo e (MCo co) = Cast e co - -- We are careful to use (MCo co) only when co is not reflexive - -- Hence (Cast e co) rather than (mkCast e co) - -mkPiMCo :: Var -> MCoercionR -> MCoercionR -mkPiMCo _ MRefl = MRefl -mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) - --------------- -etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr --- See Note [The EtaInfo mechanism] -etaInfoAbs eis expr - | null eis = expr - | otherwise = case final_mco of - MRefl -> expr' - MCo co -> mkCast expr' co - where - (expr', final_mco) = foldr do_one (split_cast expr) eis - - do_one :: EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion) - -- Implements the "Abstraction" column in the comments for data EtaInfo - -- In both argument and result the pair (e,mco) denotes (e |> mco) - do_one (EtaVar v) (expr, mco) = (Lam v expr, mkPiMCo v mco) - do_one (EtaCo co) (expr, mco) = (expr, mco `mkTransMCoL` mkSymCo co) - - split_cast :: CoreExpr -> (CoreExpr, MCoercion) - split_cast (Cast e co) = (e, MCo co) - split_cast e = (e, MRefl) - -- We could look in the body of lets, and the branches of a case - -- But then we would have to worry about whether the cast mentioned - -- any of the bound variables, which is tiresome. Later maybe. - -- Result: we may end up with - -- (\(x::Int). case x of { DEFAULT -> e1 |> co }) |> sym (->co) - -- and fail to optimise it away - --------------- -etaInfoApp :: InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr +etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr -- (etaInfoApp s e eis) returns something equivalent to -- (substExpr s e `appliedto` eis) -- See Note [The EtaInfo mechanism] @@ -1477,13 +1417,16 @@ etaInfoApp in_scope expr eis = go (mkEmptySubst in_scope) expr eis where - go :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr + go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr -- 'go' pushed down the eta-infos into the branch of a case -- and the body of a let; and does beta-reduction if possible + -- go subst fun co [b1,..,bn] returns (subst(fun) |> co) b1 .. bn go subst (Tick t e) eis = Tick (substTickish subst t) (go subst e eis) - go subst (Cast e co) eis - = go subst e (pushCoercion (Core.substCo subst co) eis) + + go subst (Cast e co) (EI bs mco) + = go subst e (EI bs (Core.substCo subst co `mkTransMCoR` mco)) + go subst (Case e b ty alts) eis = Case (Core.substExprSC subst e) b1 ty' alts' where @@ -1492,37 +1435,42 @@ ty' = etaInfoAppTy (Core.substTy subst ty) eis subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis) where - (subst2,bs') = Core.substBndrs subst1 bs + (subst2,bs') = Core.substBndrs subst1 bs + go subst (Let b e) eis | not (isJoinBind b) -- See Note [Eta expansion for join points] = Let b' (go subst' e eis) where (subst', b') = Core.substBindSC subst b - -- Beta-reduction if possible, using getArg_maybe to push - -- any intervening casts past the argument - -- See Note [The EtaInfo mechansim] - go subst (Lam v e) eis - | Just (arg, eis') <- getArg_maybe eis - = go (Core.extendSubst subst v arg) e eis' + -- Beta-reduction if possible, pushing any intervening casts past + -- the argument. See Note [The EtaInfo mechansim] + go subst (Lam v e) (EI (b:bs) mco) + | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b) + = go (Core.extendSubst subst v arg) e (EI bs mco') -- Stop pushing down; just wrap the expression up - go subst e eis = wrap (Core.substExprSC subst e) eis - - wrap e [] = e - wrap e (EtaVar v : eis) = wrap (App e (varToCoreExpr v)) eis - wrap e (EtaCo co : eis) = wrap (Cast e co) eis - + go subst e (EI bs mco) = Core.substExprSC subst e + `mkCastMCo` mco + `mkVarApps` bs -------------- -etaInfoAppTy :: Type -> [EtaInfo] -> Type +etaInfoAppTy :: Type -> EtaInfo -> Type -- If e :: ty -- then etaInfoApp e eis :: etaInfoApp ty eis -etaInfoAppTy ty [] = ty -etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis -etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis +etaInfoAppTy ty (EI bs mco) + = applyTypeToArgs (text "etaInfoAppTy") ty1 (map varToCoreExpr bs) + where + ty1 = case mco of + MRefl -> ty + MCo co -> coercionRKind co -------------- +etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr +-- See Note [The EtaInfo mechanism] +etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco + +-------------- -- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding -- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the -- free variables of @e@. @@ -1538,26 +1486,28 @@ -> InScopeSet -- ^ A super-set of the free vars of the expression to eta-expand. -> Type - -> (InScopeSet, [EtaInfo]) + -> (InScopeSet, EtaInfo) -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'. -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the -- fresh variables in 'EtaInfo'. mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty - = go 0 orig_oss empty_subst orig_ty [] + = go 0 orig_oss empty_subst orig_ty where empty_subst = mkEmptyTCvSubst in_scope go :: Int -- For fresh names -> [OneShotInfo] -- Number of value args to expand to -> TCvSubst -> Type -- We are really looking at subst(ty) - -> [EtaInfo] -- Accumulating parameter - -> (InScopeSet, [EtaInfo]) - go _ [] subst _ eis -- See Note [exprArity invariant] + -> (InScopeSet, EtaInfo) + -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co) + -- co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr + + go _ [] subst _ -- See Note [exprArity invariant] ----------- Done! No more expansion needed - = (getTCvInScope subst, reverse eis) + = (getTCvInScope subst, EI [] MRefl) - go n oss@(one_shot:oss1) subst ty eis -- See Note [exprArity invariant] + go n oss@(one_shot:oss1) subst ty -- See Note [exprArity invariant] ----------- Forall types (forall a. ty) | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty , (subst', tcv') <- Type.substVarBndr subst tcv @@ -1565,19 +1515,21 @@ | otherwise = oss1 -- A forall can bind a CoVar, in which case -- we consume one of the [OneShotInfo] - = go n oss' subst' ty' (EtaVar tcv' : eis) + , (in_scope, EI bs mco) <- go n oss' subst' ty' + = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco)) ----------- Function types (t1 -> t2) | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty , not (isTypeLevPoly arg_ty) - -- See Note [Levity polymorphism invariants] in GHC.Core + -- See Note [Representation polymorphism invariants] in GHC.Core -- See also test case typecheck/should_run/EtaExpandLevPoly , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty) -- Avoid free vars of the original expression , let eta_id' = eta_id `setIdOneShotInfo` one_shot - = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis) + , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty + = (in_scope, EI (eta_id' : bs) (mkFunResMCo (idScaledType eta_id') mco)) ----------- Newtypes -- Given this: @@ -1587,17 +1539,20 @@ -- We want to get -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) | Just (co, ty') <- topNormaliseNewType_maybe ty - , let co' = Type.substCo subst co + , -- co :: ty ~ ty' + let co' = Type.substCo subst co -- Remember to apply the substitution to co (#16979) -- (or we could have applied to ty, but then -- we'd have had to zap it for the recursive call) - = go n oss subst ty' (pushCoercion co' eis) + , (in_scope, EI bs mco) <- go n oss subst ty' + -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr + = (in_scope, EI bs (mkTransMCoR co' mco)) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function, or a binder - -- is levity-polymorphic + -- is representation-polymorphic = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr ) - (getTCvInScope subst, reverse eis) + (getTCvInScope subst, EI [] MRefl) -- This *can* legitimately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is -- playing fast and loose with types (Happy does this a lot). @@ -1635,13 +1590,16 @@ ; return (arg':args', m_co2) } MRefl -> return (arg':args, MRefl) } +pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +pushMCoArg MRefl arg = Just (arg, MRefl) +pushMCoArg (MCo co) arg = pushCoArg co arg + pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype -- C.f. simplCast in GHC.Core.Opt.Simplify -- 'co' is always Representational --- If the returned coercion is Nothing, then it would have been reflexive pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty ; return (Type ty', m_co') } pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co @@ -1727,7 +1685,7 @@ Pair tyL tyR = coercionKind co pushCoercionIntoLambda - :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) + :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) -- This implements the Push rule from the paper on coercions -- (\x. e) |> co -- ===> diff --git a/GHC/Core/Opt/CallerCC.hs b/GHC/Core/Opt/CallerCC.hs --- a/GHC/Core/Opt/CallerCC.hs +++ b/GHC/Core/Opt/CallerCC.hs @@ -10,19 +10,19 @@ -- flag. module GHC.Core.Opt.CallerCC ( addCallerCostCentres - , CallerCcFilter + , CallerCcFilter(..) + , NamePattern(..) , parseCallerCcFilter ) where -import Data.Bifunctor import Data.Word (Word8) import Data.Maybe -import qualified Text.Parsec as P import Control.Applicative import Control.Monad.Trans.State.Strict import Data.Either import Control.Monad +import qualified Text.ParserCombinators.ReadP as P import GHC.Prelude import GHC.Utils.Outputable as Outputable @@ -42,6 +42,7 @@ import GHC.Core.Opt.Monad import GHC.Utils.Panic import qualified GHC.Utils.Binary as B +import Data.Char addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do @@ -170,17 +171,17 @@ = go rest s || go (PWildcard rest) (tail s) go _ _ = False -type Parser = P.Parsec String () +type Parser = P.ReadP parseNamePattern :: Parser NamePattern parseNamePattern = pattern where - pattern = star <|> wildcard <|> char <|> end + pattern = star P.<++ wildcard P.<++ char P.<++ end star = PChar '*' <$ P.string "\\*" <*> pattern wildcard = do void $ P.char '*' PWildcard <$> pattern - char = PChar <$> P.anyChar <*> pattern + char = PChar <$> P.get <*> pattern end = PEnd <$ P.eof data CallerCcFilter @@ -199,8 +200,10 @@ put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y parseCallerCcFilter :: String -> Either String CallerCcFilter -parseCallerCcFilter = - first show . P.parse parseCallerCcFilter' "caller-CC filter" +parseCallerCcFilter inp = + case P.readP_to_S parseCallerCcFilter' inp of + ((result, ""):_) -> Right result + _ -> Left $ "parse error on " ++ inp parseCallerCcFilter' :: Parser CallerCcFilter parseCallerCcFilter' = @@ -217,8 +220,8 @@ moduleName :: Parser String moduleName = do - c <- P.upper - cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_" - rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName + c <- P.satisfy isUpper + cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_') + rest <- optional $ P.char '.' >> fmap ('.':) moduleName return $ c : (cs ++ fromMaybe "" rest) diff --git a/GHC/Core/Opt/ConstantFold.hs b/GHC/Core/Opt/ConstantFold.hs --- a/GHC/Core/Opt/ConstantFold.hs +++ b/GHC/Core/Opt/ConstantFold.hs @@ -485,11 +485,11 @@ -- coercions - Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] - Int16ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] - Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] + Int8ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + Int16ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] + Int32ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] #if WORD_SIZE_IN_BITS < 64 - Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ] + Int64ToIntOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ] #endif IntToInt8Op -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit , semiInversePrimOp Int8ToIntOp @@ -504,17 +504,17 @@ IntToInt64Op -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ] #endif - Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit + Word8ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit , extendNarrowPassthrough WordToWord8Op 0xFF ] - Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit + Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit , extendNarrowPassthrough WordToWord16Op 0xFFFF ] - Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit + Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF ] #if WORD_SIZE_IN_BITS < 64 - Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ] + Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ] #endif WordToWord8Op -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs --- a/GHC/Core/Opt/DmdAnal.hs +++ b/GHC/Core/Opt/DmdAnal.hs @@ -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. + -} diff --git a/GHC/Core/Opt/Monad.hs b/GHC/Core/Opt/Monad.hs --- a/GHC/Core/Opt/Monad.hs +++ b/GHC/Core/Opt/Monad.hs @@ -165,16 +165,17 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad = SimplMode - { sm_names :: [String] -- ^ Name(s) of the phase - , sm_phase :: CompilerPhase - , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options - , sm_rules :: !Bool -- ^ Whether RULES are enabled - , sm_inline :: !Bool -- ^ Whether inlining is enabled - , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled - , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled - , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled - , sm_logger :: !Logger - , sm_dflags :: DynFlags + { sm_names :: [String] -- ^ Name(s) of the phase + , sm_phase :: CompilerPhase + , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options + , sm_rules :: !Bool -- ^ Whether RULES are enabled + , sm_inline :: !Bool -- ^ Whether inlining is enabled + , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled + , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled + , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? + , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_logger :: !Logger + , sm_dflags :: DynFlags -- Just for convenient non-monadic access; we don't override these. -- -- Used for: @@ -188,6 +189,7 @@ instance Outputable SimplMode where ppr (SimplMode { sm_phase = p, sm_names = ss , sm_rules = r, sm_inline = i + , sm_cast_swizzle = cs , sm_eta_expand = eta, sm_case_case = cc }) = text "SimplMode" <+> braces ( sep [ text "Phase =" <+> ppr p <+> @@ -195,6 +197,7 @@ , pp_flag i (sLit "inline") <> comma , pp_flag r (sLit "rules") <> comma , pp_flag eta (sLit "eta-expand") <> comma + , pp_flag cs (sLit "cast-swizzle") <> comma , pp_flag cc (sLit "case-of-case") ]) where pp_flag f s = ppUnless f (text "no") <+> ptext s diff --git a/GHC/Core/Opt/Pipeline.hs b/GHC/Core/Opt/Pipeline.hs --- a/GHC/Core/Opt/Pipeline.hs +++ b/GHC/Core/Opt/Pipeline.hs @@ -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 diff --git a/GHC/Core/Opt/Simplify.hs b/GHC/Core/Opt/Simplify.hs --- a/GHC/Core/Opt/Simplify.hs +++ b/GHC/Core/Opt/Simplify.hs @@ -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. -} + diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -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. + ************************************************************************ * * diff --git a/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/GHC/Core/Opt/Specialise.hs @@ -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 } diff --git a/GHC/Core/Opt/WorkWrap.hs b/GHC/Core/Opt/WorkWrap.hs --- a/GHC/Core/Opt/WorkWrap.hs +++ b/GHC/Core/Opt/WorkWrap.hs @@ -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 }) diff --git a/GHC/Core/Opt/WorkWrap/Utils.hs b/GHC/Core/Opt/WorkWrap/Utils.hs --- a/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/GHC/Core/Opt/WorkWrap/Utils.hs @@ -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 diff --git a/GHC/Core/Ppr.hs b/GHC/Core/Ppr.hs --- a/GHC/Core/Ppr.hs +++ b/GHC/Core/Ppr.hs @@ -22,6 +22,7 @@ pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprCoreBindingWithSize, pprCoreBindingsWithSize, + pprCoreBinder, pprCoreBinders, pprRules, pprOptCo ) where @@ -356,7 +357,6 @@ Note [Binding-site specific printing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust the information printed. @@ -394,6 +394,10 @@ = getPprDebug $ \debug -> pprTypedLamBinder bind_site debug bndr +pprCoreBinders :: [Var] -> SDoc +-- Print as lambda-binders, i.e. with their type +pprCoreBinders vs = sep (map (pprCoreBinder LambdaBind) vs) + pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder | isTyVar binder = text "@" <> ppr binder -- NB: don't print kind @@ -643,8 +647,7 @@ ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [text "forall" <+> - sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + 4 (sep [text "forall" <+> pprCoreBinders tpl_vars <> dot, nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (text "=" <+> pprCoreExpr rhs) ]) diff --git a/GHC/Core/Rules.hs b/GHC/Core/Rules.hs --- a/GHC/Core/Rules.hs +++ b/GHC/Core/Rules.hs @@ -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 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 + ). But for rule-matching we /do/ want to match template + (f a) against target (\x. f x), with a := + + 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 diff --git a/GHC/Core/SimpleOpt.hs b/GHC/Core/SimpleOpt.hs --- a/GHC/Core/SimpleOpt.hs +++ b/GHC/Core/SimpleOpt.hs @@ -1175,7 +1175,12 @@ -- Look through dictionary functions; see Note [Unfolding DFuns] | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding , bndrs `equalLength` args -- See Note [DFun arity check] - , let subst = mkOpenSubst in_scope (bndrs `zip` args) + , let in_scope' = extend_in_scope (exprsFreeVars dfun_args) + subst = mkOpenSubst in_scope' (bndrs `zip` args) + -- We extend the in-scope set here to silence warnings from + -- substExpr when it finds not-in-scope Ids in dfun_args. + -- simplOptExpr initialises the in-scope set with exprFreeVars, + -- but that doesn't account for DFun unfoldings = succeedWith in_scope floats $ pushCoDataCon con (map (substExpr subst) dfun_args) co @@ -1186,7 +1191,7 @@ -- CPR'd workers getting inlined back into their wrappers, | idArity fun == 0 , Just rhs <- expandUnfolding_maybe unfolding - , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + , let in_scope' = extend_in_scope (exprFreeVars rhs) = go (Left in_scope') floats rhs cont -- See Note [exprIsConApp_maybe on literal strings] @@ -1198,6 +1203,11 @@ dealWithStringLiteral fun str co where unfolding = id_unf fun + extend_in_scope unf_fvs + | isLocalId fun = in_scope `extendInScopeSetSet` unf_fvs + | otherwise = in_scope + -- A GlobalId has no (LocalId) free variables; and the + -- in-scope set tracks only LocalIds go _ _ _ _ = Nothing @@ -1318,8 +1328,9 @@ "map coerce = coerce" match. -} -exprIsLambda_maybe :: InScopeEnv -> CoreExpr - -> Maybe (Var, CoreExpr,[CoreTickish]) +exprIsLambda_maybe :: HasDebugCallStack + => InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[CoreTickish]) -- See Note [exprIsLambda_maybe] -- The simple case: It is a lambda already diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs --- a/GHC/Core/Subst.hs +++ b/GHC/Core/Subst.hs @@ -24,7 +24,7 @@ emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, delBndr, delBndrs, @@ -39,8 +39,6 @@ import GHC.Prelude -import GHC.Driver.Ppr - import GHC.Core import GHC.Core.FVs import GHC.Core.Seq @@ -68,6 +66,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import Data.List (mapAccumL) +import GHC.Driver.Ppr @@ -255,9 +254,9 @@ | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' - -- Vital! See Note [Extending the Subst] + | otherwise = WARN( True, text "GHC.Core.Subst.lookupIdSubst" <+> ppr v - $$ ppr in_scope) + $$ ppr in_scope) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' @@ -292,12 +291,6 @@ ------------------------------ isInScope :: Var -> Subst -> Bool isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope - --- | Add the 'Var' to the in-scope set, but do not remove --- any existing substitutions for it -addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs cvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it diff --git a/GHC/Core/TyCo/FVs.hs b/GHC/Core/TyCo/FVs.hs --- a/GHC/Core/TyCo/FVs.hs +++ b/GHC/Core/TyCo/FVs.hs @@ -650,7 +650,7 @@ tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc -tyCoFVsOfProv CorePrepProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv (CorePrepProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc @@ -720,8 +720,8 @@ = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv = almost_devoid_co_var_of_co co cv -almost_devoid_co_var_of_prov (PluginProv _) _ = True -almost_devoid_co_var_of_prov CorePrepProv _ = True +almost_devoid_co_var_of_prov (PluginProv _) _ = True +almost_devoid_co_var_of_prov (CorePrepProv _) _ = True almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True diff --git a/GHC/Core/TyCo/Rep.hs b/GHC/Core/TyCo/Rep.hs --- a/GHC/Core/TyCo/Rep.hs +++ b/GHC/Core/TyCo/Rep.hs @@ -169,10 +169,10 @@ | CastTy Type KindCoercion -- ^ A kind cast. The coercion is always nominal. - -- INVARIANT: The cast is never reflexive - -- INVARIANT: The Type is not a CastTy (use TransCo instead) - -- INVARIANT: The Type is not a ForAllTy over a type variable - -- See Note [Respecting definitional equality] \(EQ2), (EQ3), (EQ4) + -- INVARIANT: The cast is never reflexive \(EQ2) + -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3) + -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4) + -- See Note [Respecting definitional equality] | CoercionTy Coercion -- ^ Injection of a Coercion into a type @@ -305,6 +305,31 @@ In a FunTy { ft_af = InvisArg }, the argument type is always a Predicate type. +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here are the typing rules for ForAllTy: + +tyvar : Type +inner : TYPE r +tyvar does not occur in r +------------------------------------ +ForAllTy (Bndr tyvar vis) inner : TYPE r + +inner : TYPE r +------------------------------------ +ForAllTy (Bndr covar vis) inner : Type + +Note that the kind of the result depends on whether the binder is a +tyvar or a covar. The kind of a forall-over-tyvar is the same as +the kind of the inner type. This is because quantification over types +is erased before runtime. By contrast, the kind of a forall-over-covar +is always Type, because a forall-over-covar is compiled into a function +taking a 0-bit-wide erased coercion argument. + +Because the tyvar form above includes r in its result, we must +be careful not to let any variables escape -- thus the last premise +of the rule above. + Note [Constraints in kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do we allow a type constructor to have a kind like @@ -455,7 +480,7 @@ are interchangeable. But let's be more precise. If we examine the typing rules of FC (say, those in -https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +https://richarde.dev/papers/2015/equalities/equalities.pdf) there are several places where the same metavariable is used in two different premises to a rule. (For example, see Ty_App.) There is an implicit equality check here. What definition of equality should we use? By convention, we use @@ -473,7 +498,7 @@ those rules must also be admissible. A more drawn out argument around all of this is presented in Section 7.2 of -Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). +Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf). What would go wrong if we insisted on the casts matching? See the beginning of Section 8 in the unpublished paper above. Theoretically, nothing at all goes @@ -485,8 +510,8 @@ and we would need enormous casts with lots of CoherenceCo's to straighten them out. -Would anything go wrong if eqType respected type families? No, not at all. But -that makes eqType rather hard to implement. +Would anything go wrong if eqType looked through type families? No, not at +all. But that makes eqType rather hard to implement. Thus, the guideline for eqType is that it should be the largest easy-to-implement relation that is still smaller than ~ and homogeneous. The @@ -500,6 +525,23 @@ This principle also tells us that eqType must relate only types with the same kinds. +Interestingly, it must be the case that the free variables of t1 and t2 +might be different, even if t1 `eqType` t2. A simple example of this is +if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment. +Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free +vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement +eqType to be just α-equivalence, this wrinkle around free variables +remains. + +Yet not all is lost: we can say that any two equal types share the same +*relevant* free variables. Here, a relevant variable is a shallow +free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs) +that does not appear within a coercion. Note that type variables can +appear within coercions (in, say, a Refl node), but that coercion variables +cannot appear outside a coercion. We do not (yet) have a function to +extract relevant free variables, but it would not be hard to write if +the need arises. + Besides eqType, another equality relation that upholds the (EQ) property above is /typechecker equality/, which is implemented as GHC.Tc.Utils.TcType.tcEqType. See @@ -528,7 +570,7 @@ Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done -in mkCastTy. +in mkCastTy. This is (EQ1) below. Unforunately, that's not the end of the story. Consider comparing (T a b c) =? (T a b |> (co -> )) (c |> co) @@ -551,6 +593,7 @@ In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). +This is (EQ2) below. One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly, @@ -573,6 +616,25 @@ These invariants are all documented above, in the declaration for Type. +Note [Equality on FunTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A (FunTy vis mult arg res) is just an abbreviation for a + TyConApp funTyCon [mult, arg_rep, res_rep, arg, res] +where + arg :: TYPE arg_rep + res :: TYPE res_rep +Note that the vis field of a FunTy appears nowhere in the +equivalent TyConApp. In Core, this is OK, because we no longer +care about the visibility of the argument in a FunTy +(the vis distinguishes between arg -> res and arg => res). +In the type-checker, we are careful not to decompose FunTys +with an invisible argument. See also Note [Decomposing fat arrow c=>t] +in GHC.Core.Type. + +In order to compare FunTys while respecting how they could +expand into TyConApps, we must check +the kinds of the arg and the res. + Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have @@ -1541,7 +1603,9 @@ | PluginProv String -- ^ From a plugin, which asserts that this coercion -- is sound. The string is for the use of the plugin. - | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Pprep + | CorePrepProv -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep + Bool -- True <=> the UnivCo must be homogeneously kinded + -- False <=> allow hetero-kinded, e.g. Int ~ Int# deriving Data.Data @@ -1549,7 +1613,7 @@ ppr (PhantomProv _) = text "(phantom)" ppr (ProofIrrelProv _) = text "(proof irrel.)" ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) - ppr CorePrepProv = text "(CorePrep)" + ppr (CorePrepProv _) = text "(CorePrep)" -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole @@ -1861,7 +1925,7 @@ go_prov env (PhantomProv co) = go_co env co go_prov env (ProofIrrelProv co) = go_co env co go_prov _ (PluginProv _) = mempty - go_prov _ CorePrepProv = mempty + go_prov _ (CorePrepProv _) = mempty {- ********************************************************************* * * @@ -1918,7 +1982,7 @@ provSize (PhantomProv co) = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _) = 1 -provSize CorePrepProv = 1 +provSize (CorePrepProv _) = 1 {- ************************************************************************ diff --git a/GHC/Core/TyCo/Subst.hs b/GHC/Core/TyCo/Subst.hs --- a/GHC/Core/TyCo/Subst.hs +++ b/GHC/Core/TyCo/Subst.hs @@ -852,7 +852,7 @@ go_prov (PhantomProv kco) = PhantomProv (go kco) go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) go_prov p@(PluginProv _) = p - go_prov p@CorePrepProv = p + go_prov p@(CorePrepProv _) = p -- See Note [Substituting in a coercion hole] go_hole h@(CoercionHole { ch_co_var = cv }) diff --git a/GHC/Core/TyCo/Tidy.hs b/GHC/Core/TyCo/Tidy.hs --- a/GHC/Core/TyCo/Tidy.hs +++ b/GHC/Core/TyCo/Tidy.hs @@ -250,7 +250,7 @@ go_prov (PhantomProv co) = PhantomProv $! go co go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co go_prov p@(PluginProv _) = p - go_prov p@CorePrepProv = p + go_prov p@(CorePrepProv _) = p tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env) diff --git a/GHC/Core/TyCon/RecWalk.hs b/GHC/Core/TyCon/RecWalk.hs --- a/GHC/Core/TyCon/RecWalk.hs +++ b/GHC/Core/TyCon/RecWalk.hs @@ -22,6 +22,7 @@ import GHC.Core.TyCon import GHC.Core.TyCon.Env +import GHC.Utils.Outputable {- ************************************************************************ @@ -73,6 +74,9 @@ data RecTcChecker = RC !Int (TyConEnv Int) -- The upper bound, and the number of times -- we have encountered each TyCon + +instance Outputable RecTcChecker where + ppr (RC n env) = text "RC:" <> int n <+> ppr env -- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. initRecTc :: RecTcChecker diff --git a/GHC/Core/Type.hs b/GHC/Core/Type.hs --- a/GHC/Core/Type.hs +++ b/GHC/Core/Type.hs @@ -43,6 +43,7 @@ tcSplitTyConApp_maybe, splitListTyConApp_maybe, repSplitTyConApp_maybe, + tcRepSplitTyConApp_maybe, mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys, @@ -581,7 +582,7 @@ go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) go_prov _ p@(PluginProv _) = p - go_prov _ p@CorePrepProv = p + go_prov _ p@(CorePrepProv _) = p -- the "False" and "const" are to accommodate the type of -- substForAllCoBndrUsing, which is general enough to @@ -915,7 +916,7 @@ go_prov env (PhantomProv co) = PhantomProv <$> go_co env co go_prov env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co go_prov _ p@(PluginProv _) = return p - go_prov _ p@CorePrepProv = return p + go_prov _ p@(CorePrepProv _) = return p {- @@ -1059,14 +1060,17 @@ -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 }) - | InvisArg <- af - = Nothing -- See Note [Decomposing fat arrow c=>t] - | otherwise + | VisArg <- af -- See Note [Decomposing fat arrow c=>t] + + -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, + -- Wrinkle around FunTy + , Just rep1 <- getRuntimeRep_maybe ty1 + , Just rep2 <- getRuntimeRep_maybe ty2 = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2) - where - rep1 = getRuntimeRep ty1 - rep2 = getRuntimeRep ty2 + | otherwise + = Nothing + tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcRepSplitAppTy_maybe (TyConApp tc tys) | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc @@ -1473,30 +1477,39 @@ tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' -tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy VisArg w arg res) - | Just arg_rep <- getRuntimeRep_maybe arg - , Just res_rep <- getRuntimeRep_maybe res - = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) -tcSplitTyConApp_maybe _ = Nothing + | otherwise = tcRepSplitTyConApp_maybe ty ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with. +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy _ w arg res) + -- NB: we're in Core, so no check for VisArg + = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) + where + arg_rep = getRuntimeRep arg + res_rep = getRuntimeRep res +repSplitTyConApp_maybe _ = Nothing + +tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. -- -- Moreover, for a FunTy, it only succeeds if the argument types -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires. This will usually be true; -- but may be temporarily false during canonicalization: -- see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical --- -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (FunTy _ w arg res) +-- and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, +-- Wrinkle around FunTy +tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcRepSplitTyConApp_maybe (FunTy VisArg w arg res) + -- NB: VisArg. See Note [Decomposing fat arrow c=>t] | Just arg_rep <- getRuntimeRep_maybe arg , Just res_rep <- getRuntimeRep_maybe res = Just (funTyCon, [w, arg_rep, res_rep, arg, res]) -repSplitTyConApp_maybe _ = Nothing +tcRepSplitTyConApp_maybe _ = Nothing ------------------- -- | Attempts to tease a list type apart and gives the type of the elements if @@ -2508,6 +2521,17 @@ comparing type variables is nondeterministic, note the call to nonDetCmpVar in nonDetCmpTypeX. See Note [Unique Determinism] for more details. + +Note [Computing equality on types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several places within GHC that depend on the precise choice of +definitional equality used. If we change that definition, all these places +must be updated. This Note merely serves as a place for all these places +to refer to, so searching for references to this Note will find every place +that needs to be updated. + +See also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep. + -} nonDetCmpType :: Type -> Type -> Ordering @@ -2537,6 +2561,7 @@ nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep + -- See Note [Computing equality on types] nonDetCmpTypeX env orig_t1 orig_t2 = case go env orig_t1 orig_t2 of -- If there are casts then we also need to do a comparison of the kinds of @@ -2591,7 +2616,10 @@ | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2) - = go env s1 s2 `thenCmpTy` go env t1 t2 `thenCmpTy` go env w1 w2 + -- NB: nonDepCmpTypeX does the kind check requested by + -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep + = liftOrdering (nonDetCmpTypeX env s1 s2 `thenCmp` nonDetCmpTypeX env t1 t2) + `thenCmpTy` go env w1 w2 -- Comparing multiplicities last because the test is usually true go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 @@ -3109,7 +3137,7 @@ go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co go_prov _ p@(PluginProv _) = return p - go_prov _ p@CorePrepProv = return p + go_prov _ p@(CorePrepProv _) = return p {- @@ -3164,7 +3192,7 @@ go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyUniqSet - go_prov CorePrepProv = emptyUniqSet + go_prov (CorePrepProv _) = emptyUniqSet -- this last case can happen from the tyConsOfType used from -- checkTauTvUpdate diff --git a/GHC/Core/Unfold.hs b/GHC/Core/Unfold.hs --- a/GHC/Core/Unfold.hs +++ b/GHC/Core/Unfold.hs @@ -242,9 +242,13 @@ -> UnfNever -- See Note [Do not inline top-level bottoming functions] | otherwise - -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs - , ug_size = size - , ug_res = scrut_discount } + -> + + -- If you don't force this then we retain all the Ids + let !discounts = strictMap (mk_discount cased_bndrs) val_bndrs + in UnfIfGoodArgs { ug_args = discounts + , ug_size = size + , ug_res = scrut_discount } where (bndrs, body) = collectBinders expr diff --git a/GHC/Core/Unfold/Make.hs b/GHC/Core/Unfold/Make.hs --- a/GHC/Core/Unfold/Make.hs +++ b/GHC/Core/Unfold/Make.hs @@ -70,7 +70,7 @@ -- Simplify.simplUnfolding. mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding -mkSimpleUnfolding opts rhs +mkSimpleUnfolding !opts rhs = mkUnfolding opts InlineRhs False False rhs mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -801,14 +801,14 @@ Unlike the "impure unifiers" in the typechecker (the eager unifier in GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Canonical), the pure -unifier It does /not/ work up to ~. +unifier does /not/ work up to ~. The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required properties. Notation: - θ,φ substitutions + θ,φ substitutions ξ type-function-free types τ,σ other types τ♭ type τ, flattened @@ -1068,7 +1068,7 @@ -> UM () -- See Note [Specification of unification] -- Respects newtypes, PredTypes - +-- See Note [Computing equality on types] in GHC.Core.Type unify_ty env ty1 ty2 kco -- See Note [Comparing nullary type synonyms] in GHC.Core.Type. | TyConApp tc1 [] <- ty1 diff --git a/GHC/Core/UsageEnv.hs b/GHC/Core/UsageEnv.hs --- a/GHC/Core/UsageEnv.hs +++ b/GHC/Core/UsageEnv.hs @@ -52,7 +52,7 @@ scaleUsage x (MUsage y) = MUsage $ mkMultMul x y -- For now, we use extra multiplicity Bottom for empty case. -data UsageEnv = UsageEnv (NameEnv Mult) Bool +data UsageEnv = UsageEnv !(NameEnv Mult) Bool unitUE :: NamedThing n => n -> Mult -> UsageEnv unitUE x w = UsageEnv (unitNameEnv (getName x) w) False diff --git a/GHC/Core/Utils.hs b/GHC/Core/Utils.hs --- a/GHC/Core/Utils.hs +++ b/GHC/Core/Utils.hs @@ -11,7 +11,7 @@ -- | Commonly useful utilities for manipulating the Core language module GHC.Core.Utils ( -- * Constructing expressions - mkCast, + mkCast, mkCastMCo, mkPiMCo, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, bindNonRec, needsCaseBinding, mkAltExpr, mkDefaultCase, mkSingleAltCase, @@ -136,7 +136,7 @@ exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of - (fun, args) -> applyTypeToArgs e (exprType fun) args + (fun, args) -> applyTypeToArgs (pprCoreExpr e) (exprType fun) args exprType other = pprPanic "exprType" (pprCoreExpr other) @@ -264,10 +264,10 @@ -} -- Not defined with applyTypeToArg because you can't print from GHC.Core. -applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +applyTypeToArgs :: SDoc -> Type -> [CoreExpr] -> Type -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- The first argument is just for debugging, and gives some context -applyTypeToArgs e op_ty args +applyTypeToArgs pp_e op_ty args = go op_ty args where go op_ty [] = op_ty @@ -286,19 +286,27 @@ go_ty_args op_ty rev_tys args = go (piResultTys op_ty (reverse rev_tys)) args - panic_msg as = vcat [ text "Expression:" <+> pprCoreExpr e - , text "Type:" <+> ppr op_ty - , text "Args:" <+> ppr args - , text "Args':" <+> ppr as ] + panic_msg as = vcat [ text "Expression:" <+> pp_e + , text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args + , text "Args':" <+> ppr as ] +mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr +mkCastMCo e MRefl = e +mkCastMCo e (MCo co) = Cast e co + -- We are careful to use (MCo co) only when co is not reflexive + -- Hence (Cast e co) rather than (mkCast e co) -{- -************************************************************************ +mkPiMCo :: Var -> MCoercionR -> MCoercionR +mkPiMCo _ MRefl = MRefl +mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co) + + +{- ********************************************************************* * * -\subsection{Attaching notes} + Casts * * -************************************************************************ --} +********************************************************************* -} -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions @@ -338,6 +346,13 @@ $$ callStackDoc ) (Cast expr co) + +{- ********************************************************************* +* * + Attaching ticks +* * +********************************************************************* -} + -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible. mkTick :: CoreTickish -> CoreExpr -> CoreExpr @@ -2483,8 +2498,7 @@ , let mult = idMult bndr , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort - = let reflCo = mkRepReflCo (idType bndr) - in Just (mkFunCo Representational (multToCo mult) reflCo co, []) + = Just (mkFunResCo Representational (idScaledType bndr) co, []) ok_arg bndr (Cast e co_arg) co fun_ty | (ticks, Var v) <- stripTicksTop tickishFloatable e , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty diff --git a/GHC/CoreToIface.hs b/GHC/CoreToIface.hs --- a/GHC/CoreToIface.hs +++ b/GHC/CoreToIface.hs @@ -313,8 +313,7 @@ go_prov (PhantomProv co) = IfacePhantomProv (go co) go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) go_prov (PluginProv str) = IfacePluginProv str - go_prov CorePrepProv = pprPanic "toIfaceCoercionX" empty - -- CorePrepProv only happens after the iface file is generated + go_prov (CorePrepProv b) = IfaceCorePrepProv b toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet diff --git a/GHC/CoreToStg/Prep.hs b/GHC/CoreToStg/Prep.hs --- a/GHC/CoreToStg/Prep.hs +++ b/GHC/CoreToStg/Prep.hs @@ -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 diff --git a/GHC/Data/StringBuffer.hs b/GHC/Data/StringBuffer.hs --- a/GHC/Data/StringBuffer.hs +++ b/GHC/Data/StringBuffer.hs @@ -46,8 +46,12 @@ -- * Parsing integers parseUnsignedInteger, - ) where + -- * Checking for bi-directional format characters + containsBidirectionalFormatChar, + bidirectionalFormatChars + ) where + #include "HsVersions.h" import GHC.Prelude @@ -214,6 +218,58 @@ (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in return (C# c#, StringBuffer buf len cur') + + +bidirectionalFormatChars :: [(Char,String)] +bidirectionalFormatChars = + [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)") + , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)") + , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)") + , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)") + , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)") + , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)") + , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)") + , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)") + , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)") + ] + +{-| Returns true if the buffer contains Unicode bi-directional formatting +characters. + +https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types + +Bidirectional format characters are one of +'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)" +'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)" +'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)" +'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)" +'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)" +'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)" +'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)" +'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)" +'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)" + +This list is encoded in 'bidirectionalFormatChars' + +-} +{-# INLINE containsBidirectionalFormatChar #-} +containsBidirectionalFormatChar :: StringBuffer -> Bool +containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#)) + = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do + let go :: Int# -> Bool + go i | isTrue# (i >=# len#) = False + | otherwise = case utf8DecodeCharAddr# a# i of + (# '\x202a'# , _ #) -> True + (# '\x202b'# , _ #) -> True + (# '\x202c'# , _ #) -> True + (# '\x202d'# , _ #) -> True + (# '\x202e'# , _ #) -> True + (# '\x2066'# , _ #) -> True + (# '\x2067'# , _ #) -> True + (# '\x2068'# , _ #) -> True + (# '\x2069'# , _ #) -> True + (# _, bytes #) -> go (i +# bytes) + pure $! go cur# -- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous -- to 'Data.List.head'). __Warning:__ The behavior is undefined if the diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -128,6 +128,7 @@ | Opt_DoCmmLinting | Opt_DoAsmLinting | Opt_DoAnnotationLinting + | Opt_DoBoundsChecking | Opt_NoLlvmMangler -- hidden flag | Opt_FastLlvm -- hidden flag | Opt_NoTypeableBinds @@ -266,6 +267,7 @@ | Opt_Ticky_Dyn_Thunk | Opt_RPath | Opt_RelativeDynlibPaths + | Opt_CompactUnwind -- ^ @-fcompact-unwind@ | Opt_Hpc | Opt_FamAppCache | Opt_ExternalInterpreter @@ -512,6 +514,7 @@ | Opt_WarnAmbiguousFields -- Since 9.2 | Opt_WarnImplicitLift -- Since 9.2 | Opt_WarnMissingKindSignatures -- Since 9.2 + | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2 deriving (Eq, Ord, Show, Enum) -- | Used when outputting warnings: if a reason is given, it is diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -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 "HsVersions.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 } diff --git a/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/GHC/Driver/Make.hs @@ -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 -- ----------------------------------------------------------------------------- -- diff --git a/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/GHC/Driver/Pipeline.hs @@ -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 diff --git a/GHC/Driver/Pipeline/Monad.hs b/GHC/Driver/Pipeline/Monad.hs --- a/GHC/Driver/Pipeline/Monad.hs +++ b/GHC/Driver/Pipeline/Monad.hs @@ -27,7 +27,6 @@ import GHC.Types.SourceFile import GHC.Unit.Module -import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Module.Status @@ -82,7 +81,7 @@ -- ^ additional object files resulting from compiling foreign -- code. They come from two sources: foreign stubs, and -- add{C,Cxx,Objc,Objcxx}File from template haskell - iface :: Maybe (ModIface, ModDetails) + iface :: Maybe ModIface -- ^ Interface generated by HscOut phase. Only available after the -- phase runs. } @@ -90,7 +89,7 @@ pipeStateDynFlags :: PipeState -> DynFlags pipeStateDynFlags = hsc_dflags . hsc_env -pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) +pipeStateModIface :: PipeState -> Maybe ModIface pipeStateModIface = iface data PipelineOutput @@ -139,5 +138,5 @@ setForeignOs os = P $ \_env state -> return (state{ foreign_os = os }, ()) -setIface :: ModIface -> ModDetails -> CompPipeline () -setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ()) +setIface :: ModIface -> CompPipeline () +setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ()) diff --git a/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------- -- @@ -41,6 +42,7 @@ DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed, dynamicOutputFile, dynamicOutputHi, sccProfilingEnabled, + needSourceNotes, DynFlags(..), outputFile, hiSuf, objectSuf, ways, FlagSpec(..), @@ -881,13 +883,28 @@ opt_i dflags= toolSettings_opt_i $ toolSettings dflags -- | The directory for this version of ghc in the user's app directory --- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- The appdir used to be in ~/.ghc but to respect the XDG specification +-- we want to move it under $XDG_DATA_HOME/ +-- However, old tooling (like cabal) might still write package environments +-- to the old directory, so we prefer that if a subdirectory of ~/.ghc +-- with the correct target and GHC version suffix exists. -- +-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that +-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR +-- +-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath versionedAppDir appname platform = do -- Make sure we handle the case the HOME isn't set (see #11678) - appdir <- tryMaybeT $ getXdgDirectory XdgData appname - return $ appdir versionedFilePath platform + -- We need to fallback to the old scheme if the subdirectory exists. + msum $ map (checkIfExists <=< fmap ( versionedFilePath platform)) + [ tryMaybeT $ getAppUserDataDirectory appname -- this is ~/.ghc/ + , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/ + ] + where + checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case + True -> pure dir + False -> MaybeT (pure Nothing) versionedFilePath :: ArchOS -> FilePath versionedFilePath platform = uniqueSubdir platform @@ -2094,6 +2111,12 @@ (NoArg (setGeneralFlag Opt_SingleLibFolder)) , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "fcompact-unwind" + (noArgM (\dflags -> do + if platformOS (targetPlatform dflags) == OSDarwin + then return (gopt_set dflags Opt_CompactUnwind) + else do addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring." + return dflags)) ------- Specific phases -------------------------------------------- -- need to appear before -pgmL to be parsed as LLVM flags. @@ -3233,7 +3256,9 @@ flagSpec "invalid-haddock" Opt_WarnInvalidHaddock, flagSpec "operator-whitespace-ext-conflict" Opt_WarnOperatorWhitespaceExtConflict, flagSpec "operator-whitespace" Opt_WarnOperatorWhitespace, - flagSpec "implicit-lift" Opt_WarnImplicitLift + flagSpec "implicit-lift" Opt_WarnImplicitLift, + flagSpec "unicode-bidirectional-format-characters" + Opt_WarnUnicodeBidirectionalFormatCharacters ] -- | These @-\@ flags can all be reversed with @-no-\@ @@ -3386,6 +3411,7 @@ flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, flagSpec "catch-bottoms" Opt_CatchBottoms, flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "check-prim-bounds" Opt_DoBoundsChecking, flagSpec "num-constant-folding" Opt_NumConstantFolding, flagSpec "show-warning-groups" Opt_ShowWarnGroups, flagSpec "hide-source-paths" Opt_HideSourcePaths, @@ -4890,6 +4916,11 @@ -- | Indicate if cost-centre profiling is enabled sccProfilingEnabled :: DynFlags -> Bool sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags) + +-- | Indicate whether we need to generate source notes +needSourceNotes :: DynFlags -> Bool +needSourceNotes dflags = debugLevel dflags > 0 + || gopt Opt_InfoTableMap dflags -- ----------------------------------------------------------------------------- -- Linker/compiler information diff --git a/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs --- a/GHC/HsToCore/Binds.hs +++ b/GHC/HsToCore/Binds.hs @@ -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) diff --git a/GHC/HsToCore/Coverage.hs b/GHC/HsToCore/Coverage.hs --- a/GHC/HsToCore/Coverage.hs +++ b/GHC/HsToCore/Coverage.hs @@ -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 diff --git a/GHC/HsToCore/Pmc/Solver.hs b/GHC/HsToCore/Pmc/Solver.hs --- a/GHC/HsToCore/Pmc/Solver.hs +++ b/GHC/HsToCore/Pmc/Solver.hs @@ -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. -} ------------------------- diff --git a/GHC/Iface/Load.hs b/GHC/Iface/Load.hs --- a/GHC/Iface/Load.hs +++ b/GHC/Iface/Load.hs @@ -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. diff --git a/GHC/Iface/Syntax.hs b/GHC/Iface/Syntax.hs --- a/GHC/Iface/Syntax.hs +++ b/GHC/Iface/Syntax.hs @@ -1690,6 +1690,7 @@ freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet +freeNamesIfProv (IfaceCorePrepProv _) = emptyNameSet freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr diff --git a/GHC/Iface/Type.hs b/GHC/Iface/Type.hs --- a/GHC/Iface/Type.hs +++ b/GHC/Iface/Type.hs @@ -397,6 +397,7 @@ = IfacePhantomProv IfaceCoercion | IfaceProofIrrelProv IfaceCoercion | IfacePluginProv String + | IfaceCorePrepProv Bool -- See defn of CorePrepProv {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -596,7 +597,8 @@ go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) - go_prov (IfacePluginProv str) = IfacePluginProv str + go_prov co@(IfacePluginProv _) = co + go_prov co@(IfaceCorePrepProv _) = co substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args @@ -1755,6 +1757,8 @@ = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s) = text "plugin" <+> doubleQuotes (text s) +pprIfaceUnivCoProv (IfaceCorePrepProv _) + = text "CorePrep" ------------------- instance Outputable IfaceTyCon where @@ -2112,6 +2116,9 @@ put_ bh (IfacePluginProv a) = do putByte bh 3 put_ bh a + put_ bh (IfaceCorePrepProv a) = do + putByte bh 4 + put_ bh a get bh = do tag <- getByte bh @@ -2122,6 +2129,8 @@ return $ IfaceProofIrrelProv a 3 -> do a <- get bh return $ IfacePluginProv a + 4 -> do a <- get bh + return (IfaceCorePrepProv a) _ -> panic ("get IfaceUnivCoProv " ++ show tag) diff --git a/GHC/Iface/UpdateIdInfos.hs b/GHC/Iface/UpdateIdInfos.hs deleted file mode 100644 --- a/GHC/Iface/UpdateIdInfos.hs +++ /dev/null @@ -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 "HsVersions.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 diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs --- a/GHC/IfaceToCore.hs +++ b/GHC/IfaceToCore.hs @@ -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 diff --git a/GHC/Linker/Static.hs b/GHC/Linker/Static.hs --- a/GHC/Linker/Static.hs +++ b/GHC/Linker/Static.hs @@ -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 diff --git a/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs --- a/GHC/Llvm/Ppr.hs +++ b/GHC/Llvm/Ppr.hs @@ -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 diff --git a/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs --- a/GHC/Llvm/Syntax.hs +++ b/GHC/Llvm/Syntax.hs @@ -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 diff --git a/GHC/Parser.y b/GHC/Parser.y --- a/GHC/Parser.y +++ b/GHC/Parser.y @@ -1157,10 +1157,10 @@ ----------------------------------------------------------------------------- -- Fixity Declarations -prec :: { Located (SourceText,Int) } - : {- empty -} { noLoc (NoSourceText,9) } +prec :: { Maybe (Located (SourceText,Int)) } + : {- empty -} { Nothing } | INTEGER - { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) } + { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) } infix :: { Located FixityDirection } : 'infix' { sL1 $1 InfixN } @@ -2550,10 +2550,18 @@ ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }} | infix prec ops - {% checkPrecP $2 $3 >> - acsA (\cs -> sLL $1 $> $ SigD noExtField - (FixSig (EpAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3) - (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) } + {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3 + ; pure (mj AnnVal l2) }) + $2 + ; let (fixText, fixPrec) = case $2 of + -- If an explicit precedence isn't supplied, + -- it defaults to maxPrecedence + Nothing -> (NoSourceText, maxPrecedence) + Just l2 -> (fst $ unLoc l2, snd $ unLoc l2) + ; acsA (\cs -> sLL $1 $> $ SigD noExtField + (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3) + (Fixity fixText fixPrec (unLoc $1))))) + }} | pattern_synonym_sig { sL1 $1 . SigD noExtField . unLoc $ $1 } diff --git a/GHC/Parser/Annotation.hs b/GHC/Parser/Annotation.hs --- a/GHC/Parser/Annotation.hs +++ b/GHC/Parser/Annotation.hs @@ -492,11 +492,11 @@ -- new AST fragments out of old ones, and have them still printed out -- in a precise way. data EpAnn ann - = EpAnn { entry :: Anchor + = EpAnn { entry :: !Anchor -- ^ Base location for the start of the syntactic element -- holding the annotations. - , anns :: ann -- ^ Annotations added by the Parser - , comments :: EpAnnComments + , anns :: !ann -- ^ Annotations added by the Parser + , comments :: !EpAnnComments -- ^ Comments enclosed in the SrcSpan of the element -- this `EpAnn` is attached to } @@ -563,7 +563,10 @@ -- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with -- an extra annotation type. This is mapped to a specific `GenLocated` -- usage in the AST through the `XRec` and `Anno` type families. -data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan } + +-- Important that the fields are strict as these live inside L nodes which +-- are live for a long time. +data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan } deriving (Data, Eq) -- See Note [XRec and Anno in the AST] diff --git a/GHC/Parser/Errors.hs b/GHC/Parser/Errors.hs --- a/GHC/Parser/Errors.hs +++ b/GHC/Parser/Errors.hs @@ -30,6 +30,7 @@ import GHC.Utils.Outputable (SDoc) import GHC.Data.FastString import GHC.Unit.Module.Name +import Data.List.NonEmpty (NonEmpty) -- | A warning that might arise during parsing. data PsWarning @@ -39,6 +40,14 @@ { tabFirst :: !SrcSpan -- ^ First occurrence of a tab , tabCount :: !Word -- ^ Number of other occurrences } + + {-| PsWarnBidirectionalFormatChars is a warning (controlled by the -Wwarn-bidirectional-format-characters flag) + that occurs when unicode bi-directional format characters are found within in a file + + The 'PsLoc' contains the exact position in the buffer the character occured, and the + string contains a description of the character. + -} + | PsWarnBidirectionalFormatChars (NonEmpty (PsLoc, Char, String)) | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason -- ^ Transitional layout warnings diff --git a/GHC/Parser/Errors/Ppr.hs b/GHC/Parser/Errors/Ppr.hs --- a/GHC/Parser/Errors/Ppr.hs +++ b/GHC/Parser/Errors/Ppr.hs @@ -24,6 +24,7 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) +import Data.List.NonEmpty (NonEmpty((:|))) mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc mkParserErr span doc = MsgEnvelope @@ -61,6 +62,20 @@ TransLayout_Where -> "`where' clause at the same depth as implicit layout block" TransLayout_Pipe -> "`|' at the same depth as implicit layout block" ) + + PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs) + -> mkParserWarn Opt_WarnUnicodeBidirectionalFormatCharacters (RealSrcSpan (realSrcLocSpan $ psRealLoc loc) Nothing) $ + text "A unicode bidirectional formatting character" <+> parens (text desc) + $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file" + $$ (case xs of + [] -> empty + xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs + where + pprChars [] = empty + pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc + $$ pprChars xs + ) + $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors" PsWarnUnrecognisedPragma loc -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $ diff --git a/GHC/Settings/Config.hs b/GHC/Settings/Config.hs --- a/GHC/Settings/Config.hs +++ b/GHC/Settings/Config.hs @@ -22,7 +22,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "8.10.4" +cBooterVersion = "8.10.7" cStage :: String cStage = show (2 :: Int) diff --git a/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs --- a/GHC/Stg/Debug.hs +++ b/GHC/Stg/Debug.hs @@ -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 diff --git a/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/GHC/StgToCmm/CgUtils.hs @@ -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 diff --git a/GHC/StgToCmm/Foreign.hs b/GHC/StgToCmm/Foreign.hs --- a/GHC/StgToCmm/Foreign.hs +++ b/GHC/StgToCmm/Foreign.hs @@ -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] ]) ] diff --git a/GHC/StgToCmm/Foreign.hs-boot b/GHC/StgToCmm/Foreign.hs-boot new file mode 100644 --- /dev/null +++ b/GHC/StgToCmm/Foreign.hs-boot @@ -0,0 +1,6 @@ +module GHC.StgToCmm.Foreign where + +import GHC.Cmm +import GHC.StgToCmm.Monad + +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () diff --git a/GHC/StgToCmm/Hpc.hs b/GHC/StgToCmm/Hpc.hs --- a/GHC/StgToCmm/Hpc.hs +++ b/GHC/StgToCmm/Hpc.hs @@ -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 diff --git a/GHC/StgToCmm/Layout.hs b/GHC/StgToCmm/Layout.hs --- a/GHC/StgToCmm/Layout.hs +++ b/GHC/StgToCmm/Layout.hs @@ -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 -> diff --git a/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/GHC/StgToCmm/Monad.hs @@ -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 diff --git a/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/GHC/StgToCmm/Prim.hs @@ -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 diff --git a/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs --- a/GHC/StgToCmm/Prof.hs +++ b/GHC/StgToCmm/Prof.hs @@ -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 diff --git a/GHC/StgToCmm/Ticky.hs b/GHC/StgToCmm/Ticky.hs --- a/GHC/StgToCmm/Ticky.hs +++ b/GHC/StgToCmm/Ticky.hs @@ -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 diff --git a/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/GHC/StgToCmm/Utils.hs @@ -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) diff --git a/GHC/SysTools/Info.hs b/GHC/SysTools/Info.hs --- a/GHC/SysTools/Info.hs +++ b/GHC/SysTools/Info.hs @@ -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"]) diff --git a/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs --- a/GHC/Tc/Deriv/Generate.hs +++ b/GHC/Tc/Deriv/Generate.hs @@ -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] {- ************************************************************************ diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs --- a/GHC/Tc/Errors.hs +++ b/GHC/Tc/Errors.hs @@ -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 diff --git a/GHC/Tc/Gen/App.hs b/GHC/Tc/Gen/App.hs --- a/GHC/Tc/Gen/App.hs +++ b/GHC/Tc/Gen/App.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Tc/Gen/Bind.hs b/GHC/Tc/Gen/Bind.hs --- a/GHC/Tc/Gen/Bind.hs +++ b/GHC/Tc/Gen/Bind.hs @@ -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 diff --git a/GHC/Tc/Gen/Head.hs b/GHC/Tc/Gen/Head.hs --- a/GHC/Tc/Gen/Head.hs +++ b/GHC/Tc/Gen/Head.hs @@ -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 diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs --- a/GHC/Tc/Gen/HsType.hs +++ b/GHC/Tc/Gen/HsType.hs @@ -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' diff --git a/GHC/Tc/Gen/Rule.hs b/GHC/Tc/Gen/Rule.hs --- a/GHC/Tc/Gen/Rule.hs +++ b/GHC/Tc/Gen/Rule.hs @@ -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 diff --git a/GHC/Tc/Solver.hs b/GHC/Tc/Solver.hs --- a/GHC/Tc/Solver.hs +++ b/GHC/Tc/Solver.hs @@ -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, ), where + + * is the result of + findInferredDiff (Eq a, C a) + in GHC.Tc.Gen.Bind.chooseInferredQuantifiers + + * 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 , 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] diff --git a/GHC/Tc/Solver/Canonical.hs b/GHC/Tc/Solver/Canonical.hs --- a/GHC/Tc/Solver/Canonical.hs +++ b/GHC/Tc/Solver/Canonical.hs @@ -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 diff --git a/GHC/Tc/Solver/Rewrite.hs b/GHC/Tc/Solver/Rewrite.hs --- a/GHC/Tc/Solver/Rewrite.hs +++ b/GHC/Tc/Solver/Rewrite.hs @@ -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 diff --git a/GHC/Tc/TyCl/Utils.hs b/GHC/Tc/TyCl/Utils.hs --- a/GHC/Tc/TyCl/Utils.hs +++ b/GHC/Tc/TyCl/Utils.hs @@ -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 diff --git a/GHC/Tc/Utils/Instantiate.hs b/GHC/Tc/Utils/Instantiate.hs --- a/GHC/Tc/Utils/Instantiate.hs +++ b/GHC/Tc/Utils/Instantiate.hs @@ -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 diff --git a/GHC/Tc/Utils/Monad.hs b/GHC/Tc/Utils/Monad.hs --- a/GHC/Tc/Utils/Monad.hs +++ b/GHC/Tc/Utils/Monad.hs @@ -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 {- ************************************************************************ diff --git a/GHC/Tc/Utils/TcMType.hs b/GHC/Tc/Utils/TcMType.hs --- a/GHC/Tc/Utils/TcMType.hs +++ b/GHC/Tc/Utils/TcMType.hs @@ -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 diff --git a/GHC/Tc/Utils/TcType.hs b/GHC/Tc/Utils/TcType.hs --- a/GHC/Tc/Utils/TcType.hs +++ b/GHC/Tc/Utils/TcType.hs @@ -627,6 +627,10 @@ But in fact (GivenInv) is automatically true, so we're adhering to it for now. See #18929. +* If a tyvar tv has level n, then the levels of all variables free + in tv's kind are <= n. Consequence: if tv is untouchable, so are + all variables in tv's kind. + Note [WantedInv] ~~~~~~~~~~~~~~~~ Why is WantedInv important? Consider this implication, where @@ -1593,6 +1597,7 @@ -> Type -> Type -> Bool -- Flags False, False is the usual setting for tc_eq_type +-- See Note [Computing equality on types] in Type tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 = go orig_env orig_ty1 orig_ty2 where @@ -1622,10 +1627,14 @@ -- Make sure we handle all FunTy cases since falling through to the -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked -- kind variable, which causes things to blow up. + -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check + -- kinds here go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2) - = go env w1 w2 && go env arg1 arg2 && go env res1 res2 - go env ty (FunTy _ w arg res) = eqFunTy env w arg res ty - go env (FunTy _ w arg res) ty = eqFunTy env w arg res ty + = kinds_eq && go env arg1 arg2 && go env res1 res2 && go env w1 w2 + where + kinds_eq | vis_only = True + | otherwise = go env (typeKind arg1) (typeKind arg2) && + go env (typeKind res1) (typeKind res2) -- See Note [Equality on AppTys] in GHC.Core.Type go env (AppTy s1 t1) ty2 @@ -1660,25 +1669,6 @@ orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] - -- @eqFunTy w arg res ty@ is True when @ty@ equals @FunTy w arg res@. This is - -- sometimes hard to know directly because @ty@ might have some casts - -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't - -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or - -- res is unzonked. Thus this function, which handles this - -- corner case. - eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool - -- Last arg is /not/ FunTy - eqFunTy env w arg res ty@(AppTy{}) = get_args ty [] - where - get_args :: Type -> [Type] -> Bool - get_args (AppTy f x) args = get_args f (x:args) - get_args (CastTy t _) args = get_args t args - get_args (TyConApp tc tys) args - | tc == funTyCon - , [w', _, _, arg', res'] <- tys ++ args - = go env w w' && go env arg arg' && go env res res' - get_args _ _ = False - eqFunTy _ _ _ _ _ = False {-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. {- Note [Typechecker equality vs definitional equality] diff --git a/GHC/Types/Demand.hs b/GHC/Types/Demand.hs --- a/GHC/Types/Demand.hs +++ b/GHC/Types/Demand.hs @@ -357,7 +357,7 @@ viewProd n (Prod ds) | ds `lengthIs` n = Just ds -- Note the strict application to replicate: This makes sure we don't allocate -- a thunk for it, inlines it and lets case-of-case fire at call sites. -viewProd n (Poly card) = Just (replicate n $! polyDmd card) +viewProd n (Poly card) = Just $! (replicate n $! polyDmd card) viewProd _ _ = Nothing {-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation -- for Arity. Otherwise, #18304 bites us. @@ -386,7 +386,7 @@ lubSubDmd :: SubDemand -> SubDemand -> SubDemand -- Handle Prod lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) = - Prod $ zipWith lubDmd ds2 ds1 -- try to fuse with ds2 + Prod $ strictZipWith lubDmd ds2 ds1 -- try to fuse with ds2 -- Handle Call lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2)) -- See Note [Call demands are relative] @@ -1084,7 +1084,7 @@ -- Subject to Note [Default demand on free variables and arguments] type DmdEnv = VarEnv Demand -emptyDmdEnv :: VarEnv Demand +emptyDmdEnv :: DmdEnv emptyDmdEnv = emptyVarEnv multDmdEnv :: Card -> DmdEnv -> DmdEnv @@ -1118,9 +1118,9 @@ -- * Diverges on every code path or not ('dt_div') data DmdType = DmdType - { dt_env :: DmdEnv -- ^ Demand on explicitly-mentioned free variables - , dt_args :: [Demand] -- ^ Demand on arguments - , dt_div :: Divergence -- ^ Whether evaluation diverges. + { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables + , dt_args :: ![Demand] -- ^ Demand on arguments + , dt_div :: !Divergence -- ^ Whether evaluation diverges. -- See Note [Demand type Divergence] } @@ -1225,9 +1225,10 @@ peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) (DmdType fv' ds res, dmd) where - fv' = fv `delVarEnv` id + -- Force these arguments so that old `Env` is not retained. + !fv' = fv `delVarEnv` id -- See Note [Default demand on free variables and arguments] - dmd = lookupVarEnv fv id `orElse` defaultFvDmd res + !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res addDemand :: Demand -> DmdType -> DmdType addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res diff --git a/GHC/Types/Id.hs b/GHC/Types/Id.hs --- a/GHC/Types/Id.hs +++ b/GHC/Types/Id.hs @@ -66,6 +66,7 @@ isRecordSelector, isNaughtyRecordSelector, isPatSynRecordSelector, isDataConRecordSelector, + isClassOpId, isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, @@ -458,6 +459,7 @@ isDataConWorkId :: Id -> Bool isDataConWrapId :: Id -> Bool isDFunId :: Id -> Bool +isClassOpId :: Id -> Bool isClassOpId_maybe :: Id -> Maybe Class isPrimOpId_maybe :: Id -> Maybe PrimOp @@ -480,6 +482,10 @@ isNaughtyRecordSelector id = case Var.idDetails id of RecSelId { sel_naughty = n } -> n _ -> False + +isClassOpId id = case Var.idDetails id of + ClassOpId _ -> True + _other -> False isClassOpId_maybe id = case Var.idDetails id of ClassOpId cls -> Just cls diff --git a/GHC/Types/Literal.hs b/GHC/Types/Literal.hs --- a/GHC/Types/Literal.hs +++ b/GHC/Types/Literal.hs @@ -58,7 +58,7 @@ -- ** Coercions , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit - , extendIntLit, extendWordLit + , convertToIntLit, convertToWordLit , charToIntLit, intToCharLit , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit , nullAddrLit, floatToDoubleLit, doubleToFloatLit @@ -682,13 +682,14 @@ narrowWord32Lit = narrowLit' @Word32 LitNumWord32 narrowWord64Lit = narrowLit' @Word64 LitNumWord64 --- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g. --- 'Int#'). -extendWordLit, extendIntLit :: Platform -> Literal -> Literal -extendWordLit platform (LitNumber _nt i) = mkLitWord platform i -extendWordLit _platform l = pprPanic "extendWordLit" (ppr l) -extendIntLit platform (LitNumber _nt i) = mkLitInt platform i -extendIntLit _platform l = pprPanic "extendIntLit" (ppr l) +-- | Extend or narrow a fixed-width literal (e.g. 'Int16#') to a target +-- word-sized literal ('Int#' or 'Word#'). Narrowing can only happen on 32-bit +-- architectures when we convert a 64-bit literal into a 32-bit one. +convertToWordLit, convertToIntLit :: Platform -> Literal -> Literal +convertToWordLit platform (LitNumber _nt i) = mkLitWordWrap platform i +convertToWordLit _platform l = pprPanic "convertToWordLit" (ppr l) +convertToIntLit platform (LitNumber _nt i) = mkLitIntWrap platform i +convertToIntLit _platform l = pprPanic "convertToIntLit" (ppr l) charToIntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) charToIntLit l = pprPanic "charToIntLit" (ppr l) diff --git a/GHC/Types/Name/Env.hs b/GHC/Types/Name/Env.hs --- a/GHC/Types/Name/Env.hs +++ b/GHC/Types/Name/Env.hs @@ -134,6 +134,7 @@ elemNameEnv x y = elemUFM x y plusNameEnv x y = plusUFM x y plusNameEnv_C f x y = plusUFM_C f x y +{-# INLINE plusNameEnv_CD #-} plusNameEnv_CD f x d y b = plusUFM_CD f x d y b plusNameEnv_CD2 f x y = plusUFM_CD2 f x y extendNameEnv_C f x y z = addToUFM_C f x y z diff --git a/GHC/Types/Name/Reader.hs b/GHC/Types/Name/Reader.hs --- a/GHC/Types/Name/Reader.hs +++ b/GHC/Types/Name/Reader.hs @@ -486,10 +486,10 @@ -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt - = GRE { gre_name :: GreName -- ^ See Note [GreNames] - , gre_par :: Parent -- ^ See Note [Parents] - , gre_lcl :: Bool -- ^ True <=> the thing was defined locally - , gre_imp :: [ImportSpec] -- ^ In scope through these imports + = GRE { gre_name :: !GreName -- ^ See Note [GreNames] + , gre_par :: !Parent -- ^ See Note [Parents] + , gre_lcl :: !Bool -- ^ True <=> the thing was defined locally + , gre_imp :: ![ImportSpec] -- ^ In scope through these imports } deriving (Data, Eq) -- INVARIANT: either gre_lcl = True or gre_imp is non-empty -- See Note [GlobalRdrElt provenance] diff --git a/GHC/Types/Unique/DFM.hs b/GHC/Types/Unique/DFM.hs --- a/GHC/Types/Unique/DFM.hs +++ b/GHC/Types/Unique/DFM.hs @@ -72,6 +72,7 @@ import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable +import qualified Data.IntMap.Strict as MS import qualified Data.IntMap as M import Data.Data import Data.Functor.Classes (Eq1 (..)) @@ -122,7 +123,7 @@ -- | A type of values tagged with insertion time data TaggedVal val = TaggedVal - val + !val {-# UNPACK #-} !Int -- ^ insertion time deriving stock (Data, Functor, Foldable, Traversable) @@ -175,20 +176,24 @@ -- The new binding always goes to the right of existing ones addToUDFM_Directly :: UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_Directly (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i -- Keep the old tag, but insert the new value -- This means that udfmToList typically returns elements -- in the order of insertion, rather than the reverse + -- It is quite critical that the strict insertWith is used as otherwise + -- the combination function 'tf' is not forced and both old values are retained + -- in the map. + addToUDFM_C_Directly :: (elt -> elt -> elt) -- old -> new -> result -> UniqDFM key elt -> Unique -> elt -> UniqDFM key elt addToUDFM_C_Directly f (UDFM m i) u v - = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + = UDFM (MS.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) where tf (TaggedVal new_v _) (TaggedVal old_v old_i) = TaggedVal (f old_v new_v) old_i @@ -400,7 +405,10 @@ -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 -mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i +mapUDFM f (UDFM m i) = UDFM (MS.map (fmap f) m) i +-- Critical this is strict map, otherwise you get a big space leak when reloading +-- in GHCi because all old ModDetails are retained (see pruneHomePackageTable). +-- Modify with care. mapMaybeUDFM :: forall elt1 elt2 key. (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 diff --git a/GHC/Types/Unique/FM.hs b/GHC/Types/Unique/FM.hs --- a/GHC/Types/Unique/FM.hs +++ b/GHC/Types/Unique/FM.hs @@ -233,12 +233,16 @@ -- there is no entry in `m1` reps. `m2`. The domain is the union of -- the domains of `m1` and `m2`. -- +-- IMPORTANT NOTE: This function strictly applies the modification function +-- and forces the result unlike most the other functions in this module. +-- -- Representative example: -- -- @ -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 -- == {A: f 1 42, B: f 2 3, C: f 23 4 } -- @ +{-# INLINE plusUFM_CD #-} plusUFM_CD :: (elta -> eltb -> eltc) -> UniqFM key elta -- map X @@ -247,10 +251,10 @@ -> eltb -- default for Y -> UniqFM key eltc plusUFM_CD f (UFM xm) dx (UFM ym) dy - = UFM $ M.mergeWithKey + = UFM $ MS.mergeWithKey (\_ x y -> Just (x `f` y)) - (M.map (\x -> x `f` dy)) - (M.map (\y -> dx `f` y)) + (MS.map (\x -> x `f` dy)) + (MS.map (\y -> dx `f` y)) xm ym -- | `plusUFM_CD2 f m1 m2` merges the maps using `f` as the combining @@ -258,6 +262,9 @@ -- instead passed as `Nothing` to `f`. `f` can never have both its arguments -- be `Nothing`. -- +-- IMPORTANT NOTE: This function strictly applies the modification function +-- and forces the result. +-- -- `plusUFM_CD2 f m1 m2` is the same as `plusUFM_CD f (mapUFM Just m1) Nothing -- (mapUFM Just m2) Nothing`. plusUFM_CD2 @@ -266,10 +273,10 @@ -> UniqFM key eltb -- map Y -> UniqFM key eltc plusUFM_CD2 f (UFM xm) (UFM ym) - = UFM $ M.mergeWithKey + = UFM $ MS.mergeWithKey (\_ x y -> Just (Just x `f` Just y)) - (M.map (\x -> Just x `f` Nothing)) - (M.map (\y -> Nothing `f` Just y)) + (MS.map (\x -> Just x `f` Nothing)) + (MS.map (\y -> Nothing `f` Just y)) xm ym mergeUFM diff --git a/GHC/Types/Var/Env.hs b/GHC/Types/Var/Env.hs --- a/GHC/Types/Var/Env.hs +++ b/GHC/Types/Var/Env.hs @@ -64,7 +64,7 @@ rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, delBndrL, delBndrR, delBndrsL, delBndrsR, - addRnInScopeSet, + extendRnInScopeSetList, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, rnEnvL, rnEnvR, @@ -260,10 +260,10 @@ , envR = emptyVarEnv , in_scope = vars } -addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 -addRnInScopeSet env vs - | isEmptyVarSet vs = env - | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } +extendRnInScopeSetList :: RnEnv2 -> [Var] -> RnEnv2 +extendRnInScopeSetList env vs + | null vs = env + | otherwise = env { in_scope = extendInScopeSetList (in_scope env) vs } rnInScope :: Var -> RnEnv2 -> Bool rnInScope x env = x `elemInScopeSet` in_scope env diff --git a/GHC/Unit/Home/ModInfo.hs b/GHC/Unit/Home/ModInfo.hs --- a/GHC/Unit/Home/ModInfo.hs +++ b/GHC/Unit/Home/ModInfo.hs @@ -38,9 +38,11 @@ -- ^ The basic loaded interface file: every loaded module has one of -- these, even if it is imported from another package - , hm_details :: !ModDetails + , hm_details :: ModDetails -- ^ Extra information that has been created from the 'ModIface' for -- the module, typically during typechecking + + -- This field is LAZY because a ModDetails is constructed by knot tying. , hm_linkable :: !(Maybe Linkable) -- ^ The actual artifact we would like to link to access things in diff --git a/GHC/Unit/Module/Status.hs b/GHC/Unit/Module/Status.hs --- a/GHC/Unit/Module/Status.hs +++ b/GHC/Unit/Module/Status.hs @@ -28,7 +28,6 @@ -- ^ Information for the code generator. , hscs_mod_location :: !ModLocation -- ^ Module info - , hscs_mod_details :: !ModDetails , hscs_partial_iface :: !PartialModIface -- ^ Partial interface , hscs_old_iface_hash :: !(Maybe Fingerprint) diff --git a/GHC/Utils/Misc.hs b/GHC/Utils/Misc.hs --- a/GHC/Utils/Misc.hs +++ b/GHC/Utils/Misc.hs @@ -85,7 +85,7 @@ transitiveClosure, -- * Strictness - seqList, strictMap, + seqList, strictMap, strictZipWith, -- * Module names looksLikeModuleName, @@ -1062,6 +1062,16 @@ let !x' = f x !xs' = strictMap f xs + in + x' : xs' + +strictZipWith :: (a -> b -> c) -> [a] -> [b] -> [c] +strictZipWith _ [] _ = [] +strictZipWith _ _ [] = [] +strictZipWith f (x : xs) (y: ys) = + let + !x' = f x y + !xs' = strictZipWith f xs ys in x' : xs' diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -1,9 +1,9 @@ -- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. -Cabal-Version: >=1.22 +Cabal-Version: 1.22 Name: ghc -Version: 9.2.1 +Version: 9.2.2 License: BSD3 License-File: LICENSE Author: The GHC Team @@ -71,11 +71,9 @@ hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*, - parsec, - ghc-boot == 9.2.1, - ghc-heap == 9.2.1, - ghci == 9.2.1, - unbuildable < 0 + ghc-boot == 9.2.2, + ghc-heap == 9.2.2, + ghci == 9.2.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13 @@ -91,6 +89,7 @@ if flag(internal-interpreter) CPP-Options: -DHAVE_INTERNAL_INTERPRETER + Include-Dirs: -- if no dynamic system linker is available, don't try DLLs. if flag(dynamic-system-linker) @@ -455,7 +454,6 @@ GHC.Iface.Tidy.StaticPtrTable GHC.IfaceToCore GHC.Iface.Type - GHC.Iface.UpdateIdInfos GHC.Linker GHC.Linker.Dynamic GHC.Linker.ExtraObj