diff options
author | Ben Gamari <ben@smart-cactus.org> | 2019-01-30 10:05:19 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2019-01-30 10:05:19 -0500 |
commit | 172a59335fa6c76b17fb6795e87fbc7fcfd198e6 (patch) | |
tree | 6e5e940cb2c6ae9110807fa0d637a280c63b4220 /compiler | |
parent | 76c8fd674435a652c75a96c85abbf26f1f221876 (diff) | |
download | haskell-172a59335fa6c76b17fb6795e87fbc7fcfd198e6.tar.gz |
Revert "Batch merge"
This reverts commit 76c8fd674435a652c75a96c85abbf26f1f221876.
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/hieFile/HieAst.hs | 84 | ||||
-rw-r--r-- | compiler/nativeGen/X86/CodeGen.hs | 83 | ||||
-rw-r--r-- | compiler/nativeGen/X86/Instr.hs | 6 | ||||
-rw-r--r-- | compiler/nativeGen/X86/Ppr.hs | 2 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 41 |
5 files changed, 60 insertions, 156 deletions
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index b6b5f0ccb7..401b861e30 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -28,11 +28,9 @@ import HscTypes import Module ( ModuleName, ml_hs_file ) import MonadUtils ( concatMapM, liftIO ) import Name ( Name, nameSrcSpan, setNameLoc ) -import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import SrcLoc -import TcHsSyn ( hsLitType, hsPatType ) -import Type ( mkFunTys, Type ) -import TysWiredIn ( mkListTy, mkSumTy ) +import TcHsSyn ( hsPatType ) +import Type ( Type ) import Var ( Id, Var, setVarName, varName, varType ) import HieTypes @@ -62,11 +60,11 @@ We don't care about the distinction between mono and poly bindings, so we replace all occurrences of the mono name with the poly name. -} newtype HieState = HieState - { name_remapping :: NameEnv Id + { name_remapping :: M.Map Name Id } initState :: HieState -initState = HieState emptyNameEnv +initState = HieState M.empty class ModifyState a where -- See Note [Name Remapping] addSubstitution :: a -> a -> HieState -> HieState @@ -76,7 +74,7 @@ instance ModifyState Name where instance ModifyState Id where addSubstitution mono poly hs = - hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)} modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState modifyState = foldr go id @@ -379,9 +377,7 @@ instance ToHie (Context (Located Var)) where C context (L (RealSrcSpan span) name') -> do m <- asks name_remapping - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' + let name = M.findWithDefault name' (varName name') m pure [Node (NodeInfo S.empty [] $ @@ -396,7 +392,7 @@ instance ToHie (Context (Located Name)) where toHie c = case c of C context (L (RealSrcSpan span) name') -> do m <- asks name_remapping - let name = case lookupNameEnv m name' of + let name = case M.lookup name' m of Just var -> varName var Nothing -> name' pure @@ -436,67 +432,13 @@ instance HasType (LPat GhcTc) where instance HasType (LHsExpr GhcRn) where getTypeNode (L spn e) = makeNode e spn --- | This instance tries to construct 'HieAST' nodes which include the type of --- the expression. It is not yet possible to do this efficiently for all --- expression forms, so we skip filling in the type for those inputs. --- --- 'HsApp', for example, doesn't have any type information available directly on --- the node. Our next recourse would be to desugar it into a 'CoreExpr' then --- query the type of that. Yet both the desugaring call and the type query both --- involve recursive calls to the function and argument! This is particularly --- problematic when you realize that the HIE traversal will eventually visit --- those nodes too and ask for their types again. --- --- Since the above is quite costly, we just skip cases where computing the --- expression's type is going to be expensive. --- --- See #16233 instance HasType (LHsExpr GhcTc) where - getTypeNode e@(L spn e') = lift $ - -- Some expression forms have their type immediately available - let tyOpt = case e' of - HsLit _ l -> Just (hsLitType l) - HsOverLit _ o -> Just (overLitType o) - - HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) - HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - - ExplicitList ty _ _ -> Just (mkListTy ty) - ExplicitSum ty _ _ _ -> Just (mkSumTy ty) - HsDo ty _ _ -> Just ty - HsMultiIf ty _ -> Just ty - - _ -> Nothing - - in - case tyOpt of - _ | skipDesugaring e' -> fallback - | otherwise -> do - hs_env <- Hsc $ \e w -> return (e,w) - (_,mbe) <- liftIO $ deSugarExpr hs_env e - maybe fallback (makeTypeNode e' spn . exprType) mbe - where - fallback = makeNode e' spn - - matchGroupType :: MatchGroupTc -> Type - matchGroupType (MatchGroupTc args res) = mkFunTys args res - - -- | Skip desugaring of these expressions for performance reasons. - -- - -- See impact on Haddock output (esp. missing type annotations or links) - -- before marking more things here as 'False'. See impact on Haddock - -- performance before marking more things as 'True'. - skipDesugaring :: HsExpr a -> Bool - skipDesugaring e = case e of - HsVar{} -> False - HsUnboundVar{} -> False - HsConLikeOut{} -> False - HsRecFld{} -> False - HsOverLabel{} -> False - HsIPVar{} -> False - HsWrap{} -> False - _ -> True + getTypeNode e@(L spn e') = lift $ do + hs_env <- Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + case mbe of + Just te -> makeTypeNode e' spn (exprType te) + Nothing -> makeNode e' spn instance ( ToHie (Context (Located (IdP a))) , ToHie (MatchGroup a (LHsExpr a)) diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 9591c42ede..37080b990e 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -2045,37 +2045,25 @@ genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] b | otherwise = do code_src <- getAnyReg src + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format let dst_r = getRegisterReg platform False (CmmLocal dst) - if isBmi2Enabled dflags - then do - src_r <- getNewRegNat (intFormat width) - return $ appOL (code_src src_r) $ case width of - W8 -> toOL - [ MOVZxL II8 (OpReg src_r) (OpReg src_r) -- zero-extend to 32 bit - , LZCNT II32 (OpReg src_r) dst_r -- lzcnt with extra 24 zeros - , SUB II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros - ] - W16 -> toOL - [ LZCNT II16 (OpReg src_r) dst_r - , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit - ] - _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r) - else do - let format = if width == W8 then II16 else intFormat width - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - return $ code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSR format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits + + -- The following insn sequence makes sure 'clz 0' has a defined value. + -- starting with Haswell, one could use the LZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSR format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt (2*bw-1))) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + , XOR format (OpImm (ImmInt (bw-1))) (OpReg dst_r) + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits where bw = widthInBits width platform = targetPlatform dflags + format = if width == W8 then II16 else intFormat width lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width)) genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid @@ -2085,7 +2073,6 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid dst_r = getRegisterReg platform False (CmmLocal dst) lbl1 <- getBlockIdNat lbl2 <- getBlockIdNat - let format = if width == W8 then II16 else intFormat width tmp_r <- getNewRegNat format -- New CFG Edges: @@ -2122,38 +2109,24 @@ genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid | otherwise = do code_src <- getAnyReg src + src_r <- getNewRegNat format + tmp_r <- getNewRegNat format let dst_r = getRegisterReg platform False (CmmLocal dst) - if isBmi2Enabled dflags - then do - src_r <- getNewRegNat (intFormat width) - return $ appOL (code_src src_r) $ case width of - W8 -> toOL - [ OR II32 (OpImm (ImmInt 0xFFFFFF00)) (OpReg src_r) - , TZCNT II32 (OpReg src_r) dst_r - ] - W16 -> toOL - [ TZCNT II16 (OpReg src_r) dst_r - , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) - ] - _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r - else do - -- The following insn sequence makes sure 'ctz 0' has a defined value. - -- starting with Haswell, one could use the TZCNT insn instead. - let format = if width == W8 then II16 else intFormat width - src_r <- getNewRegNat format - tmp_r <- getNewRegNat format - return $ code_src src_r `appOL` toOL - ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ - [ BSF format (OpReg src_r) tmp_r - , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) - , CMOV NE format (OpReg tmp_r) dst_r - ]) -- NB: We don't need to zero-extend the result for the - -- W8/W16 cases because the 'MOV' insn already - -- took care of implicitly clearing the upper bits + -- The following insn sequence makes sure 'ctz 0' has a defined value. + -- starting with Haswell, one could use the TZCNT insn instead. + return $ code_src src_r `appOL` toOL + ([ MOVZxL II8 (OpReg src_r) (OpReg src_r) | width == W8 ] ++ + [ BSF format (OpReg src_r) tmp_r + , MOV II32 (OpImm (ImmInt bw)) (OpReg dst_r) + , CMOV NE format (OpReg tmp_r) dst_r + ]) -- NB: We don't need to zero-extend the result for the + -- W8/W16 cases because the 'MOV' insn already + -- took care of implicitly clearing the upper bits where bw = widthInBits width platform = targetPlatform dflags + format = if width == W8 then II16 else intFormat width genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do targetExpr <- cmmMakeDynamicReference dflags diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index 5e790e481e..c47e1fae83 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -342,8 +342,6 @@ data Instr -- bit counting instructions | POPCNT Format Operand Reg -- [SSE4.2] count number of bits set to 1 - | LZCNT Format Operand Reg -- [BMI2] count number of leading zeros - | TZCNT Format Operand Reg -- [BMI2] count number of trailing zeros | BSF Format Operand Reg -- bit scan forward | BSR Format Operand Reg -- bit scan reverse @@ -473,8 +471,6 @@ x86_regUsageOfInstr platform instr DELTA _ -> noUsage POPCNT _ src dst -> mkRU (use_R src []) [dst] - LZCNT _ src dst -> mkRU (use_R src []) [dst] - TZCNT _ src dst -> mkRU (use_R src []) [dst] BSF _ src dst -> mkRU (use_R src []) [dst] BSR _ src dst -> mkRU (use_R src []) [dst] @@ -657,8 +653,6 @@ x86_patchRegsOfInstr instr env CLTD _ -> instr POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst) - LZCNT fmt src dst -> LZCNT fmt (patchOp src) (env dst) - TZCNT fmt src dst -> TZCNT fmt (patchOp src) (env dst) PDEP fmt src mask dst -> PDEP fmt (patchOp src) (patchOp mask) (env dst) PEXT fmt src mask dst -> PEXT fmt (patchOp src) (patchOp mask) (env dst) BSF fmt src dst -> BSF fmt (patchOp src) (env dst) diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index 075bb26337..bf449d044e 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -693,8 +693,6 @@ pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor") format src dst pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst) -pprInstr (LZCNT format src dst) = pprOpOp (sLit "lzcnt") format src (OpReg dst) -pprInstr (TZCNT format src dst) = pprOpOp (sLit "tzcnt") format src (OpReg dst) pprInstr (BSF format src dst) = pprOpOp (sLit "bsf") format src (OpReg dst) pprInstr (BSR format src dst) = pprOpOp (sLit "bsr") format src (OpReg dst) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 45fc5a0972..c1777759da 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -151,11 +151,10 @@ mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls ; let cxt = fromMaybe (noLoc []) mcxt ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams - ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan - ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts - ; sequence_ annsi + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (text "class") whereDots cls tparams + ; (at_defs, anns) <- fmap unzip $ mapM (eitherToP . mkATDefault) at_insts + ; sequence_ anns ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity @@ -187,7 +186,7 @@ mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) , feqn_pats = tvs , feqn_fixity = fixity , feqn_rhs = rhs }) - ; pure (f, addAnnsAt loc anns) } + ; pure (f, anns) } mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" mkATDefault _ = panic "mkATDefault: Impossible Match" @@ -204,9 +203,8 @@ mkTyData :: SrcSpan mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ; return (cL loc (DataDecl { tcdDExt = noExt, tcdLName = tc, tcdTyVars = tyvars, @@ -237,9 +235,8 @@ mkTySynonym :: SrcSpan -> P (LTyClDecl GhcPs) mkTySynonym loc lhs rhs = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (text "type") equalsDots tc tparams ; return (cL loc (SynDecl { tcdSExt = noExt , tcdLName = tc, tcdTyVars = tyvars , tcdFixity = fixity @@ -296,9 +293,8 @@ mkFamDecl :: SrcSpan -> P (LTyClDecl GhcPs) mkFamDecl loc info lhs ksig injAnn = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs - ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan - ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams - ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; tyvars <- checkTyVarsP (ppr info) equals_or_where tc tparams ; return (cL loc (FamDecl noExt (FamilyDecl { fdExt = noExt , fdInfo = info, fdLName = tc @@ -808,11 +804,13 @@ really doesn't matter! -} checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] - -> P (LHsQTyVars GhcPs, [AddAnn]) + -> P (LHsQTyVars GhcPs) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms - ; eitherToP checkedTvs } + ; (tvs, anns) <- eitherToP checkedTvs + ; anns + ; pure tvs } eitherToP :: Either (SrcSpan, SDoc) a -> P a -- Adapts the Either monad to the P monad @@ -822,14 +820,14 @@ eitherToP (Right thing) = return thing checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) ( LHsQTyVars GhcPs -- the synthesized type variables - , [AddAnn] ) -- action which adds annotations + , P () ) -- action which adds annotations -- ^ Check whether the given list of type parameters are all type variables -- (possibly with a kind signature). -- We use the Either monad because it's also called (via 'mkATDefault') from -- "Convert". checkTyVars pp_what equals_or_where tc tparms = do { (tvs, anns) <- fmap unzip $ mapM check tparms - ; return (mkHsQTvs tvs, concat anns) } + ; return (mkHsQTvs tvs, sequence_ anns) } where check (HsTypeArg ki@(L loc _)) = Left (loc, vcat [ text "Unexpected type application" <+> @@ -841,15 +839,14 @@ checkTyVars pp_what equals_or_where tc tparms <+> text "declaration for" <+> quotes (ppr tc)]) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs - -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]) + -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ()) chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = case chk ty of Left err -> Left err - Right tv -> Right (tv, reverse acc) + Right tv@(dL->L l _) -> Right (tv, addAnnsAt l (reverse acc)) -- Check that the name space is correct! - chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs) chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) |