X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMeta.hs;h=e95df4dbd5345d38996e42b1fd8e91caf5bc8252;hp=411da4074c79e0f552beeecddb6ddb3f1312e81d;hb=6e9c0431a7cf2bf1a48f01db48c6a1d41fe15a09;hpb=58521c72cec262496dabf5fffb057d25ab17a0f7 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 411da40..e95df4d 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -36,11 +36,11 @@ import PrelNames -- OccName.varName we do this by removing varName from the import of -- OccName above, making a qualified instance of OccName and using -- OccNameAlias.varName where varName ws previously used in this file. -import qualified OccName +import qualified OccName( isDataOcc, isVarOcc, isTcOcc, varName, tcName ) import Module import Id -import Name +import Name hiding( isVarOcc, isTcOcc, varName, tcName ) import NameEnv import TcType import TyCon @@ -338,10 +338,10 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch cis))) where conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls)) conv_cimportspec (CFunction DynamicTarget) = return "dynamic" - conv_cimportspec (CFunction (StaticTarget fs)) = return (unpackFS fs) + conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs) conv_cimportspec CWrapper = return "wrapper" static = case cis of - CFunction (StaticTarget _) -> "static " + CFunction (StaticTarget _ _) -> "static " _ -> "" repForD decl = notHandled "Foreign declaration" (ppr decl) @@ -435,35 +435,38 @@ rep_proto nm ty loc ; return [(loc, sig)] } -rep_inline :: Located Name -> InlineSpec -> SrcSpan +rep_inline :: Located Name + -> InlinePragma -- Never defaultInlinePragma + -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc = do { nm1 <- lookupLOcc nm - ; (_, ispec1) <- rep_InlineSpec ispec + ; ispec1 <- rep_InlinePrag ispec ; pragma <- repPragInl nm1 ispec1 ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsType Name -> InlineSpec -> SrcSpan +rep_specialise :: Located Name -> LHsType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc = do { nm1 <- lookupLOcc nm ; ty1 <- repLTy ty - ; (hasSpec, ispec1) <- rep_InlineSpec ispec - ; pragma <- if hasSpec - then repPragSpecInl nm1 ty1 ispec1 - else repPragSpec nm1 ty1 + ; pragma <- if isDefaultInlinePragma ispec + then repPragSpec nm1 ty1 -- SPECIALISE + else do { ispec1 <- rep_InlinePrag ispec -- SPECIALISE INLINE + ; repPragSpecInl nm1 ty1 ispec1 } ; return [(loc, pragma)] } --- extract all the information needed to build a TH.InlineSpec +-- Extract all the information needed to build a TH.InlinePrag -- -rep_InlineSpec :: InlineSpec -> DsM (Bool, Core TH.InlineSpecQ) -rep_InlineSpec (Inline (InlinePragma activation match) inline) +rep_InlinePrag :: InlinePragma -- Never defaultInlinePragma + -> DsM (Core TH.InlineSpecQ) +rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inline = inline }) | Nothing <- activation1 - = liftM ((,) False) $ repInlineSpecNoPhase inline1 match1 + = repInlineSpecNoPhase inline1 match1 | Just (flag, phase) <- activation1 - = liftM ((,) True) $ repInlineSpecPhase inline1 match1 flag phase + = repInlineSpecPhase inline1 match1 flag phase | otherwise = {- unreachable, but shuts up -W -} panic "rep_InlineSpec" where match1 = coreBool (rep_RuleMatchInfo match) @@ -473,8 +476,8 @@ rep_InlineSpec (Inline (InlinePragma activation match) inline) rep_RuleMatchInfo FunLike = False rep_RuleMatchInfo ConLike = True - rep_Activation NeverActive = Nothing - rep_Activation AlwaysActive = Nothing + rep_Activation NeverActive = Nothing -- We never have NOINLINE/AlwaysActive + rep_Activation AlwaysActive = Nothing -- or INLINE/NeverActive rep_Activation (ActiveBefore phase) = Just (coreBool False, MkC $ mkIntExprInt phase) rep_Activation (ActiveAfter phase) = Just (coreBool True, @@ -587,43 +590,44 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTForall bndrs1 ctxt1 ty1 repTy (HsTyVar n) - | isTvOcc (nameOccName n) = do - tv1 <- lookupTvOcc n - repTvar tv1 - | otherwise = do - tc1 <- lookupOcc n - repNamedTyCon tc1 -repTy (HsAppTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - repTapp f1 a1 -repTy (HsFunTy f a) = do - f1 <- repLTy f - a1 <- repLTy a - tcon <- repArrowTyCon - repTapps tcon [f1, a1] -repTy (HsListTy t) = do - t1 <- repLTy t - tcon <- repListTyCon - repTapp tcon t1 -repTy (HsPArrTy t) = do - t1 <- repLTy t - tcon <- repTy (HsTyVar (tyConName parrTyCon)) - repTapp tcon t1 -repTy (HsTupleTy _ tys) = do - tys1 <- repLTys tys - tcon <- repTupleTyCon (length tys) - repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) - `nlHsAppTy` ty2) -repTy (HsParTy t) = repLTy t -repTy (HsPredTy pred) = repPredTy pred -repTy (HsKindSig t k) = do - t1 <- repLTy t - k1 <- repKind k - repTSig t1 k1 -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) -repTy ty = notHandled "Exotic form of type" (ppr ty) + | isTvOcc (nameOccName n) = do + tv1 <- lookupTvOcc n + repTvar tv1 + | otherwise = do + tc1 <- lookupOcc n + repNamedTyCon tc1 +repTy (HsAppTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + repTapp f1 a1 +repTy (HsFunTy f a) = do + f1 <- repLTy f + a1 <- repLTy a + tcon <- repArrowTyCon + repTapps tcon [f1, a1] +repTy (HsListTy t) = do + t1 <- repLTy t + tcon <- repListTyCon + repTapp tcon t1 +repTy (HsPArrTy t) = do + t1 <- repLTy t + tcon <- repTy (HsTyVar (tyConName parrTyCon)) + repTapp tcon t1 +repTy (HsTupleTy _ tys) = do + tys1 <- repLTys tys + tcon <- repTupleTyCon (length tys) + repTapps tcon tys1 +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t +repTy (HsPredTy pred) = repPredTy pred +repTy (HsKindSig t k) = do + t1 <- repLTy t + k1 <- repKind k + repTSig t1 k1 +repTy (HsSpliceTy splice) = repSplice splice +repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind -- @@ -640,6 +644,21 @@ repKind ki (ppr k) ----------------------------------------------------------------------------- +-- Splices +----------------------------------------------------------------------------- + +repSplice :: HsSplice Name -> DsM (Core a) +-- See Note [How brackets and nested splices are handled] in TcSplice +-- We return a CoreExpr of any old type; the context should know +repSplice (HsSplice n _) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + _ -> pprPanic "HsSplice" (ppr n) } + -- Should not happen; statically checked + +----------------------------------------------------------------------------- -- Expressions ----------------------------------------------------------------------------- @@ -742,14 +761,8 @@ repE (ArithSeq _ aseq) = ds2 <- repLE e2 ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 -repE (HsSpliceE (HsSplice n _)) - = do { mb_val <- dsLookupMetaEnv n - ; case mb_val of - Just (Splice e) -> do { e' <- dsExpr e - ; return (MkC e') } - _ -> pprPanic "HsSplice" (ppr n) } - -- Should not happen; statically checked +repE (HsSpliceE splice) = repSplice splice repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) @@ -1000,7 +1013,9 @@ repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP (TuplePat ps _ _) = do { qs <- repLPs ps; repPtup qs } +repP p@(TuplePat ps boxed _) + | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p) + | otherwise = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of