From: Adam Megacz Date: Thu, 3 Mar 2011 01:56:21 +0000 (-0800) Subject: rebase to ghc main repo X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hp=-c rebase to ghc main repo --- 9176377bf7d989919fe7d27cad1f56bd9c4e7b6b diff --combined compiler/deSugar/Desugar.lhs index 2898460,142f695..14e4eea --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@@ -8,7 -8,6 +8,7 @@@ The Desugarer: turning HsSyn into Core \begin{code} module Desugar ( deSugar, deSugarExpr ) where +import TysWiredIn (unitDataConId) import DynFlags import StaticFlags import HscTypes @@@ -41,7 -40,6 +41,7 @@@ import MonadUtil import OrdList import Data.List import Data.IORef +import Control.Exception ( catch, ErrorCall, Exception(..) ) \end{code} %************************************************************************ @@@ -71,12 -69,13 +71,13 @@@ deSugar hsc_en tcg_anns = anns, tcg_binds = binds, tcg_imp_specs = imp_specs, - tcg_ev_binds = ev_binds, - tcg_fords = fords, - tcg_rules = rules, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) + tcg_ev_binds = ev_binds, + tcg_fords = fords, + tcg_rules = rules, + tcg_vects = vects, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Desugar" @@@ -90,7 -89,7 +91,7 @@@ <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@@ -100,19 -99,20 +101,20 @@@ (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds auto_scc binds_cvr + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds auto_scc binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; rules <- mapMaybeM dsRule rules - ; return ( ds_ev_binds + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; ds_vects <- mapM dsVect vects + ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ rules + , spec_rules ++ ds_rules, ds_vects , ds_fords, ds_hpc_info, modBreaks) } - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do { -- Add export flags to bindings keep_alive <- readIORef keep_var @@@ -136,25 -136,7 +138,25 @@@ ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - +{- + ; dumpIfSet_dyn dflags Opt_D_dump_proof "input to flattener" (text $ showSDoc $ pprCoreBindings ds_binds) + ; let uhandler (err::ErrorCall) + = dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" + (text $ "\\begin{verbatim}\n" ++ + show err ++ + "\\end{verbatim}\n\n") + in (dumpIfSet_dyn dflags Opt_D_dump_proof "System FC Proof" $ + (vcat (map (\ bind -> let e = case bind of + NonRec b e -> e + Rec lve -> Let (Rec lve) (Var unitDataConId) + in text $ "\\begin{verbatim}\n" ++ + (showSDoc $ pprCoreBindings ds_binds) ++ + "\\end{verbatim}\n\n" ++ + "$$\n"++ + (core2proofAndShow e) ++ + "$$\n" + ) ds_binds))) `Control.Exception.catch` uhandler +-} ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env @@@ -181,6 -163,7 +183,7 @@@ mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, + mg_vect_decls = ds_vects, mg_vect_info = noVectInfo } ; return (msgs, Just mod_guts) @@@ -242,7 -225,7 +245,7 @@@ deSugarExpr :: HscEn deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do let dflags = hsc_dflags hsc_env - showPass dflags "Desugar" + showPass dflags "Desugarz" -- Do desugaring (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $ @@@ -252,10 -235,8 +255,10 @@@ Nothing -> return (msgs, Nothing) Just expr -> do +{- -- Dump output - dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) + dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (text $ "$$\n"++(core2proofAndShow expr)++"$$\n") +-} return (msgs, Just expr) \end{code} @@@ -396,3 -377,26 +399,26 @@@ That keeps the desugaring of list compr Nor do we want to warn of conversion identities on the LHS; the rule is precisly to optimise them: {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + + + %************************************************************************ + %* * + %* Desugaring vectorisation declarations + %* * + %************************************************************************ + + \begin{code} + dsVect :: LVectDecl Id -> DsM CoreVect + dsVect (L loc (HsVect v rhs)) + = putSrcSpanDs loc $ + do { rhs' <- fmapMaybeM dsLExpr rhs + ; return $ Vect (unLoc v) rhs' + } + -- dsVect (L loc (HsVect v Nothing)) + -- = return $ Vect v Nothing + -- dsVect (L loc (HsVect v (Just rhs))) + -- = putSrcSpanDs loc $ + -- do { rhs' <- dsLExpr rhs + -- ; return $ Vect v (Just rhs') + -- } + \end{code} diff --combined compiler/deSugar/DsExpr.lhs index 9d1edc7,1781aef..5b566a0 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@@ -216,16 -216,6 +216,16 @@@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e + +dsExpr (HsHetMetBrak c e) = do { e' <- dsExpr (unLoc e) + ; brak <- dsLookupGlobalId hetmet_brak_name + ; return $ mkApps (Var brak) [ (Type c), (Type $ exprType e'), e'] } +dsExpr (HsHetMetEsc c t e) = do { e' <- dsExpr (unLoc e) + ; esc <- dsLookupGlobalId hetmet_esc_name + ; return $ mkApps (Var esc) [ (Type c), (Type t), e'] } +dsExpr (HsHetMetCSP c e) = do { e' <- dsExpr (unLoc e) + ; csp <- dsLookupGlobalId hetmet_csp_name + ; return $ mkApps (Var csp) [ (Type c), (Type $ exprType e'), e'] } dsExpr (ExprWithTySigOut e _) = dsLExpr e dsExpr (HsVar var) = return (Var var) dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) @@@ -378,11 -368,11 +378,11 @@@ dsExpr (ExplicitList elt_ty xs -- singletonP x1 +:+ ... +:+ singletonP xn -- dsExpr (ExplicitPArr ty []) = do - emptyP <- dsLookupGlobalId emptyPName + emptyP <- dsLookupDPHId emptyPName return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsLookupGlobalId singletonPName - appP <- dsLookupGlobalId appPName + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName xs' <- mapM dsLExpr xs return . foldr1 (binary appP) $ map (unary singletonP) xs' where diff --combined compiler/main/DynFlags.hs index a94a3f4,494cc44..3990f04 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@@ -32,7 -32,7 +32,7 @@@ module DynFlags Option(..), showOpt, DynLibLoader(..), fFlags, fLangFlags, xFlags, - DPHBackend(..), dphPackage, + DPHBackend(..), dphPackageMaybe, wayNames, -- ** Manipulating DynFlags @@@ -101,6 -101,7 +101,7 @@@ import Data.Cha import Data.List import Data.Map (Map) import qualified Data.Map as Map + import Data.Maybe import System.FilePath import System.IO ( stderr, hPutChar ) @@@ -153,8 -154,10 +154,10 @@@ data DynFla | Opt_D_dump_rn_stats | Opt_D_dump_opt_cmm | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect @@@ -308,7 -311,6 +311,7 @@@ data ExtensionFla | Opt_GHCForeignImportPrim | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax + | Opt_ModalTypes -- Heterogeneous Metaprogramming (modal types, brackets, escape, CSP) | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams @@@ -1260,7 -1262,9 +1263,9 @@@ dynamic_flags = , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , Flag "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) @@@ -1587,7 -1591,6 +1592,7 @@@ xFlags = deprecatedForExtension "DoRec"), ( "DoRec", Opt_DoRec, nop ), ( "Arrows", Opt_Arrows, nop ), + ( "ModalTypes", Opt_ModalTypes, nop ), ( "ParallelArrays", Opt_ParallelArrays, nop ), ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), ( "QuasiQuotes", Opt_QuasiQuotes, nop ), @@@ -1677,11 -1680,6 +1682,11 @@@ impliedFlag , (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll) , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) + , (Opt_ModalTypes, turnOn, Opt_RankNTypes) + , (Opt_ModalTypes, turnOn, Opt_ExplicitForAll) + , (Opt_ModalTypes, turnOn, Opt_RebindableSyntax) + , (Opt_ModalTypes, turnOff, Opt_MonomorphismRestriction) + , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! , (Opt_GADTs, turnOn, Opt_GADTSyntax) @@@ -2019,18 -2017,15 +2024,15 @@@ data DPHBackend = DPHPar -- "dph-par setDPHBackend :: DPHBackend -> DynP () setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend } - -- Query the DPH backend package to be used by the vectoriser. + -- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax. -- - dphPackage :: DynFlags -> PackageId - dphPackage dflags + dphPackageMaybe :: DynFlags -> Maybe PackageId + dphPackageMaybe dflags = case dphBackend dflags of - DPHPar -> dphParPackageId - DPHSeq -> dphSeqPackageId - DPHThis -> thisPackage dflags - DPHNone -> ghcError (CmdLineError dphBackendError) - - dphBackendError :: String - dphBackendError = "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" + DPHPar -> Just dphParPackageId + DPHSeq -> Just dphSeqPackageId + DPHThis -> Just (thisPackage dflags) + DPHNone -> Nothing setMainIs :: String -> DynP () setMainIs arg @@@ -2286,7 -2281,7 +2288,7 @@@ picCCOpts _dflag -- Splitting can_split :: Bool - can_split = cSplitObjs == "YES" + can_split = cSupportsSplitObjs == "YES" -- ----------------------------------------------------------------------------- -- Compiler Info @@@ -2303,7 -2298,7 +2305,7 @@@ compilerInfo = [("Project name" ("Host platform", String cHostPlatformString), ("Target platform", String cTargetPlatformString), ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting", String cSplitObjs), + ("Object splitting supported", String cSupportsSplitObjs), ("Have native code generator", String cGhcWithNativeCodeGen), ("Support SMP", String cGhcWithSMP), ("Unregisterised", String cGhcUnregisterised), diff --combined compiler/parser/Lexer.x index 872c7aa,5c41d72..d6b2322 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@@ -55,7 -55,6 +55,7 @@@ module Lexer getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@@ -326,15 -325,6 +326,15 @@@ $tab+ { warn Opt_WarnTabs (tex } <0> { + "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak } + "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "~~" / { ifExtension hetMetEnabled } { special ITescape } + "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } + "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } +} + +<0> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } @@@ -495,6 -485,8 +495,8 @@@ data Toke | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag | ITdotdot -- reserved symbols | ITcolon @@@ -580,13 -572,6 +582,13 @@@ | ITLarrowtail -- -<< | ITRarrowtail -- >>- + -- Heterogeneous Metaprogramming extension + | ITopenBrak -- <[ + | ITcloseBrak -- ]> + | ITescape -- ~~ + | ITescapeDollar -- ~~$ + | ITdoublePercent -- %% + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@@ -1540,8 -1525,7 +1542,8 @@@ data PState = PState alr_expecting_ocurly :: Maybe ALRLayout, -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool + alr_justClosedExplicitLetBlock :: Bool, + code_type_bracket_depth :: Int } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@@ -1608,13 -1592,6 +1610,13 @@@ setExts f = P $ \s -> POk s{ extsBitma setSrcLoc :: SrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () +incrBracketDepth :: P () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) () +decrBracketDepth :: P () +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) () +getParserBrakDepth :: P Int +getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) + getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc @@@ -1823,8 -1800,6 +1825,8 @@@ relaxedLayoutBit :: In relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True @@@ -1834,8 -1809,6 +1836,8 @@@ parrEnabled :: Int -> Boo parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool arrowsEnabled flags = testBit flags arrowsBit +hetMetEnabled :: Int -> Bool +hetMetEnabled flags = testBit flags hetMetBit thEnabled :: Int -> Bool thEnabled flags = testBit flags thBit ipEnabled :: Int -> Bool @@@ -1897,15 -1870,13 +1899,15 @@@ mkPState flags buf loc alr_last_loc = noSrcSpan, alr_context = [], alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False + alr_justClosedExplicitLetBlock = False, + code_type_bracket_depth = 0 } where bitmap = genericsBit `setBitIf` xopt Opt_Generics flags .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags @@@ -2306,13 -2277,14 +2308,14 @@@ oneWordPrags = Map.fromList([("rules", ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@@ -2331,6 -2303,7 +2334,7 @@@ clean_pragma prag = canon_ws (map toLow canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) diff --combined compiler/parser/Parser.y.pp index 3958b9c,bfadfba..62eebef --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@@ -39,7 -39,7 +39,7 @@@ import Type ( funTyCon import ForeignCall ( Safety(..), CExportSpec(..), CLabelString, CCallConv(..), CCallTarget(..), defaultCCallConv ) -import OccName ( varName, dataName, tcClsName, tvName ) +import OccName ( varName, varNameDepth, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, SrcSpan, combineLocs, srcLocFile, @@@ -266,6 -266,8 +266,8 @@@ incorrect '{-# WARNING' { L _ ITwarning_prag } '{-# UNPACK' { L _ ITunpack_prag } '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols @@@ -304,11 -306,6 +306,11 @@@ '#)' { L _ ITcubxparen } '(|' { L _ IToparenbar } '|)' { L _ ITcparenbar } + '<[' { L _ ITopenBrak } + ']>' { L _ ITcloseBrak } + '~~' { L _ ITescape } + '~~$' { L _ ITescapeDollar } + '%%' { L _ ITdoublePercent } ';' { L _ ITsemi } ',' { L _ ITcomma } '`' { L _ ITbackquote } @@@ -568,6 -565,8 +570,8 @@@ topdecl :: { OrdList (LHsDecl RdrName) | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } | annotation { unitOL $1 } | decl { unLoc $1 } @@@ -1016,7 -1015,6 +1020,7 @@@ atype :: { LHsType RdrName | '(' ctype ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } | '[' ctype ']' { LL $ HsListTy $2 } + | '<[' ctype ']>' '@' tyvar { LL $ HsModalBoxType (unLoc $5) $2 } | '[:' ctype ':]' { LL $ HsPArrTy $2 } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } @@@ -1220,7 -1218,6 +1224,7 @@@ decl :: { Located (OrdList (LHsDecl Rd | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; let { l = comb2 $1 $> }; return $! (sL l (unitOL $! (sL l $ ValD r))) } } + | docdecl { LL $ unitOL $1 } rhs :: { Located (GRHSs RdrName) } @@@ -1238,7 -1235,6 +1242,7 @@@ sigdecl :: { Located (OrdList (LHsDecl : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 ; return (LL $ unitOL (LL $ SigD s)) } -- See Note [Declaration/signature overlap] for why we need infixexp here + | var ',' sig_vars '::' sigtypedoc { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) @@@ -1263,10 -1259,6 +1267,10 @@@ quasiquote :: { Located (HsQuasiQuote R ; quoterId = mkUnqual varName quoter } in L1 (mkHsQuasiQuote quoterId quoteSpan quote) } +incdepth :: { Located () } : {% do { incrBracketDepth ; return $ noLoc () } } +decdepth :: { Located () } : {% do { decrBracketDepth ; return $ noLoc () } } + + exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } | infixexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } @@@ -1274,7 -1266,6 +1278,7 @@@ | infixexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } | infixexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} | infixexp { $1 } + | '~~$' decdepth exp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } infixexp :: { LHsExpr RdrName } : exp10 { $1 } @@@ -1405,11 -1396,6 +1409,11 @@@ aexp2 :: { LHsExpr RdrName -- arrow notation extension | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } + -- code type notation extension + | '<[' incdepth exp decdepth ']>' { sL (comb2 $3 $>) (HsHetMetBrak placeHolderType $3) } + | '~~' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetEsc placeHolderType placeHolderType $3) } + | '%%' decdepth aexp incdepth { sL (comb2 $3 $>) (HsHetMetCSP placeHolderType $3) } + cmdargs :: { [LHsCmdTop RdrName] } : cmdargs acmd { $2 : $1 } | {- empty -} { [] } @@@ -1841,7 -1827,7 +1845,7 @@@ qvarid :: { Located RdrName | PREFIXQVARSYM { L1 $! mkQual varName (getPREFIXQVARSYM $1) } varid :: { Located RdrName } - : VARID { L1 $! mkUnqual varName (getVARID $1) } + : VARID {% do { depth <- getParserBrakDepth ; return (L1 $! mkUnqual (varNameDepth depth) (getVARID $1)) } } | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } @@@ -1866,10 -1852,9 +1870,10 @@@ varsym :: { Located RdrName | '-' { L1 $ mkUnqual varName (fsLit "-") } varsym_no_minus :: { Located RdrName } -- varsym not including '-' - : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) } - | special_sym { L1 $ mkUnqual varName (unLoc $1) } - + : VARSYM {% do { depth <- getParserBrakDepth + ; return (L1 $! mkUnqual (varNameDepth depth) (getVARSYM $1)) } } + | special_sym {% do { depth <- getParserBrakDepth + ; return (L1 $! mkUnqual (varNameDepth depth) (unLoc $1)) } } -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these diff --combined compiler/prelude/PrelNames.lhs index 0f027c5,f92d94e..5c2dfa0 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@@ -89,20 -89,27 +89,27 @@@ isUnboundName name = name `hasKey` unbo %************************************************************************ - %* * + %* * \subsection{Known key Names} - %* * + %* * %************************************************************************ This section tells what the compiler knows about the assocation of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. + The names for DPH can come from one of multiple backend packages. At the point where + 'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list + the names for multiple backends. That works out fine, although they use the same uniques, + as we are guaranteed to only load one backend; hence, only one of the different names + sharing a unique will be used. + \begin{code} basicKnownKeyNames :: [Name] basicKnownKeyNames = genericTyConNames ++ typeableClassNames + ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runMainIOName, @@@ -149,7 -156,6 +156,6 @@@ -- Enum stuff enumFromName, enumFromThenName, enumFromThenToName, enumFromToName, - enumFromToPName, enumFromThenToPName, -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, @@@ -187,11 -193,6 +193,6 @@@ dollarName, -- The ($) apply function - -- Parallel array operations - nullPName, lengthPName, replicatePName, singletonPName, mapPName, - filterPName, zipPName, crossMapPName, indexPName, - toPName, emptyPName, appPName, - -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, @@@ -211,11 -212,6 +212,11 @@@ -- Other classes randomClassName, randomGenClassName, monadPlusClassName, + -- Code types + hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, + hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, + hetmet_guest_char_literal_name, + -- Annotation type checking toAnnotationWrapperName @@@ -229,6 -225,20 +230,20 @@@ genericTyConNames :: [Name] genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] + + -- Know names from the DPH package which vary depending on the selected DPH backend. + -- + dphKnownKeyNames :: PackageId -> [Name] + dphKnownKeyNames dphPkg + = map ($ dphPkg) + [ + -- Parallel array operations + nullPName, lengthPName, replicatePName, singletonPName, mapPName, + filterPName, zipPName, crossMapPName, indexPName, + toPName, emptyPName, appPName, + enumFromToPName, enumFromThenToPName + + ] \end{code} @@@ -247,8 -257,7 +262,8 @@@ pRELUDE = mkBaseModule_ pRELUDE_NAM gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_MAGIC, gHC_CLASSES, gHC_BASE, gHC_ENUM, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, + gHC_HETMET_CODETYPES, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, @@@ -271,11 -280,9 +286,10 @@@ gHC_READ = mkBaseModule (fsLit "GHC.Rea gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") - gHC_LIST = mkBaseModule (fsLit "GHC.List") - gHC_PARR = mkBaseModule (fsLit "GHC.PArr") +gHC_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes") - gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") - dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") + gHC_LIST = mkBaseModule (fsLit "GHC.List") + gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") + dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") @@@ -311,6 -318,12 +325,12 @@@ rANDOM = mkBaseModule (fsLit "System.R gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") + gHC_PARR :: PackageId -> Module + gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel")) + + gHC_PARR' :: Module + gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") + mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation @@@ -746,32 -759,22 +766,32 @@@ readClassName = clsQual gHC_READ (fs enumFromToPName, enumFromThenToPName, nullPName, lengthPName, singletonPName, replicatePName, mapPName, filterPName, zipPName, crossMapPName, indexPName, toPName, - emptyPName, appPName :: Name - enumFromToPName = varQual gHC_PARR (fsLit "enumFromToP") enumFromToPIdKey - enumFromThenToPName= varQual gHC_PARR (fsLit "enumFromThenToP") enumFromThenToPIdKey - nullPName = varQual gHC_PARR (fsLit "nullP") nullPIdKey - lengthPName = varQual gHC_PARR (fsLit "lengthP") lengthPIdKey - singletonPName = varQual gHC_PARR (fsLit "singletonP") singletonPIdKey - replicatePName = varQual gHC_PARR (fsLit "replicateP") replicatePIdKey - mapPName = varQual gHC_PARR (fsLit "mapP") mapPIdKey - filterPName = varQual gHC_PARR (fsLit "filterP") filterPIdKey - zipPName = varQual gHC_PARR (fsLit "zipP") zipPIdKey - crossMapPName = varQual gHC_PARR (fsLit "crossMapP") crossMapPIdKey - indexPName = varQual gHC_PARR (fsLit "!:") indexPIdKey - toPName = varQual gHC_PARR (fsLit "toP") toPIdKey - emptyPName = varQual gHC_PARR (fsLit "emptyP") emptyPIdKey - appPName = varQual gHC_PARR (fsLit "+:+") appPIdKey + emptyPName, appPName :: PackageId -> Name + enumFromToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP") enumFromToPIdKey + enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey + nullPName pkg = varQual (gHC_PARR pkg) (fsLit "nullP") nullPIdKey + lengthPName pkg = varQual (gHC_PARR pkg) (fsLit "lengthP") lengthPIdKey + singletonPName pkg = varQual (gHC_PARR pkg) (fsLit "singletonP") singletonPIdKey + replicatePName pkg = varQual (gHC_PARR pkg) (fsLit "replicateP") replicatePIdKey + mapPName pkg = varQual (gHC_PARR pkg) (fsLit "mapP") mapPIdKey + filterPName pkg = varQual (gHC_PARR pkg) (fsLit "filterP") filterPIdKey + zipPName pkg = varQual (gHC_PARR pkg) (fsLit "zipP") zipPIdKey + crossMapPName pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP") crossMapPIdKey + indexPName pkg = varQual (gHC_PARR pkg) (fsLit "!:") indexPIdKey + toPName pkg = varQual (gHC_PARR pkg) (fsLit "toP") toPIdKey + emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey + appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey +-- code type things +hetmet_brak_name, hetmet_esc_name, hetmet_csp_name :: Name +hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name, hetmet_guest_char_literal_name :: Name +hetmet_brak_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_brak") hetmet_brak_key +hetmet_esc_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_esc") hetmet_esc_key +hetmet_csp_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_csp") hetmet_csp_key +hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_integer_literal") hetmet_guest_integer_literal_key +hetmet_guest_string_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_string_literal") hetmet_guest_string_literal_key +hetmet_guest_char_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "hetmet_guest_char_literal") hetmet_guest_char_literal_key + -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, failIOName :: Name @@@ -1083,10 -1086,6 +1103,10 @@@ opaqueTyConKe stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 +-- Heterogeneous Metaprogramming code type constructor +hetMetCodeTypeTyConKey :: Unique +hetMetCodeTypeTyConKey = mkPreludeTyConUnique 135 + ---------------- Template Haskell ------------------- -- USES TyConUniques 100-129 ----------------------------------------------------- @@@ -1134,10 -1133,6 +1154,10 @@@ parrDataConKey = mkPreludeDataConUni leftDataConKey, rightDataConKey :: Unique leftDataConKey = mkPreludeDataConUnique 25 rightDataConKey = mkPreludeDataConUnique 26 + +-- Data constructor for Heterogeneous Metaprogramming code types +hetMetCodeTypeDataConKey :: Unique +hetMetCodeTypeDataConKey = mkPreludeDataConUnique 27 \end{code} %************************************************************************ @@@ -1330,16 -1325,6 +1350,16 @@@ realToFracIdKey = mkPreludeMiscIdU toIntegerClassOpKey = mkPreludeMiscIdUnique 129 toRationalClassOpKey = mkPreludeMiscIdUnique 130 +-- code types +hetmet_brak_key, hetmet_esc_key, hetmet_csp_key :: Unique +hetmet_brak_key = mkPreludeMiscIdUnique 131 +hetmet_esc_key = mkPreludeMiscIdUnique 132 +hetmet_csp_key = mkPreludeMiscIdUnique 133 +hetmet_guest_integer_literal_key, hetmet_guest_string_literal_key, hetmet_guest_char_literal_key :: Unique +hetmet_guest_integer_literal_key = mkPreludeMiscIdUnique 134 +hetmet_guest_string_literal_key = mkPreludeMiscIdUnique 135 +hetmet_guest_char_literal_key = mkPreludeMiscIdUnique 136 + ---------------- Template Haskell ------------------- -- USES IdUniques 200-399 ----------------------------------------------------- diff --combined compiler/prelude/TysWiredIn.lhs index aaef164,db2ea1b..29fa628 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@@ -47,12 -47,6 +47,12 @@@ module TysWiredIn -- * Unit unitTy, + -- * Heterogeneous Metaprogramming + mkHetMetCodeTypeTy, + hetMetCodeTypeTyConName, + hetMetCodeTypeTyCon, isHetMetCodeTypeTyCon, + hetMetCodeTypeTyCon_RDR, + -- * Parallel arrays mkPArrTy, parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, @@@ -130,7 -124,6 +130,7 @@@ wiredInTyCons = [ unitTyCon -- Not trea , intTyCon , listTyCon , parrTyCon + , hetMetCodeTypeTyCon , unsafeCoercionTyCon , symCoercionTyCon , transCoercionTyCon @@@ -176,17 -169,13 +176,19 @@@ doubleTyConName = mkWiredInTyConNam doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon parrTyConName, parrDataConName :: Name - parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon - parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon + parrTyConName = mkWiredInTyConName BuiltInSyntax + gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon + parrDataConName = mkWiredInDataConName UserSyntax + gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon +hetMetCodeTypeTyConName :: Name +hetMetCodeTypeTyConName = mkWiredInTyConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>@") hetMetCodeTypeTyConKey hetMetCodeTypeTyCon +hetMetCodeTypeDataConName :: Name +hetMetCodeTypeDataConName = + mkWiredInDataConName BuiltInSyntax gHC_HETMET_CODETYPES (fsLit "<[]>") hetMetCodeTypeDataConKey hetMetCodeTypeDataCon + boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, - intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, hetMetCodeTypeTyCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName true_RDR = nameRdrName trueDataConName @@@ -196,7 -185,6 +198,7 @@@ intDataCon_RDR = nameRdrName intDataCon listTyCon_RDR = nameRdrName listTyConName consDataCon_RDR = nameRdrName consDataConName parrTyCon_RDR = nameRdrName parrTyConName +hetMetCodeTypeTyCon_RDR = nameRdrName hetMetCodeTypeTyConName \end{code} @@@ -614,7 -602,7 +616,7 @@@ mkPArrFakeCon arity = data_co tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName gHC_PARR (mkDataOccFS nameStr) unique + name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique (ADataCon data_con) UserSyntax unique = mkPArrDataConUnique arity @@@ -624,26 -612,3 +626,26 @@@ isPArrFakeCon dcon = dcon == parrFakeC \end{code} +Heterogeneous Metaprogramming + +\begin{code} +-- | Construct a type representing the application of the box type +mkHetMetCodeTypeTy :: TyVar -> Type -> Type +mkHetMetCodeTypeTy ecn ty = mkTyConApp hetMetCodeTypeTyCon [(mkTyVarTy ecn), ty] + +-- | Represents the type constructor of box types +hetMetCodeTypeTyCon :: TyCon +hetMetCodeTypeTyCon = pcNonRecDataTyCon hetMetCodeTypeTyConName [alphaTyVar, betaTyVar] [hetMetCodeTypeDataCon] + +-- | Check whether a type constructor is the constructor for box types +isHetMetCodeTypeTyCon :: TyCon -> Bool +isHetMetCodeTypeTyCon tc = tyConName tc == hetMetCodeTypeTyConName + +hetMetCodeTypeDataCon :: DataCon +hetMetCodeTypeDataCon = pcDataCon + hetMetCodeTypeDataConName + [betaTyVar] -- forall'ed type variables + [betaTy] + hetMetCodeTypeTyCon + +\end{code} diff --combined compiler/typecheck/TcExpr.lhs index a068e53,6bb0820..9f960b1 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@@ -42,7 -42,6 +42,7 @@@ import DataCo import Name import TyCon import Type +import TypeRep import Coercion import Var import VarSet @@@ -50,6 -49,7 +50,7 @@@ import TysWiredI import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames + import Module import DynFlags import SrcLoc import Util @@@ -137,52 -137,12 +138,52 @@@ tcInfExpr e = tcInfer (tcEx %************************************************************************ \begin{code} + +updHetMetLevel :: ([TyVar] -> [TyVar]) -> TcM a -> TcM a +updHetMetLevel f comp = + updEnv + (\oldenv -> let oldlev = (case oldenv of Env { env_lcl = e' } -> case e' of TcLclEnv { tcl_hetMetLevel = x } -> x) + in (oldenv { env_lcl = (env_lcl oldenv) { tcl_hetMetLevel = f oldlev } })) + + comp + +addEscapes :: [TyVar] -> HsExpr Name -> HsExpr Name +addEscapes [] e = e +addEscapes (t:ts) e = HsHetMetEsc (TyVarTy t) placeHolderType (noLoc (addEscapes ts e)) + +getIdLevel :: Name -> TcM [TyVar] +getIdLevel name + = do { thing <- tcLookup name + ; case thing of + ATcId { tct_hetMetLevel = variable_hetMetLevel } -> return $ variable_hetMetLevel + _ -> return [] + } + tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId) tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e) tcExpr (HsVar name) res_ty = tcCheckId name res_ty +tcExpr (HsHetMetBrak _ e) res_ty = + do { (coi, [inferred_name,elt_ty]) <- matchExpectedTyConApp hetMetCodeTypeTyCon res_ty + ; fresh_ec_name <- newFlexiTyVar liftedTypeKind + ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) + $ tcPolyExpr e elt_ty + ; unifyType (TyVarTy fresh_ec_name) inferred_name + ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } +tcExpr (HsHetMetEsc _ _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty]) + ; ty' <- zonkTcType res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) } +tcExpr (HsHetMetCSP _ e) res_ty = + do { cur_level <- getHetMetLevel + ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) + $ tcExpr (unLoc e) res_ty + ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) } + tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit @@@ -778,7 -738,7 +779,7 @@@ tcExpr (PArrSeq _ seq@(FromTo expr1 exp ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - enumFromToPName elt_ty + (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak ; return $ mkHsWrapCoI coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } @@@ -788,7 -748,7 +789,7 @@@ tcExpr (PArrSeq _ seq@(FromThenTo expr ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) - enumFromThenToPName elt_ty + (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak ; return $ mkHsWrapCoI coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } @@@ -1001,40 -961,24 +1002,40 @@@ tcInferId n = tcInferIdWithOrig (Occurr tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType) -- Look up an occurrence of an Id, and instantiate it (deeply) -tcInferIdWithOrig orig id_name - = do { id <- lookup_id - ; (id_expr, id_rho) <- instantiateOuter orig id - ; (wrap, rho) <- deeplyInstantiate orig id_rho - ; return (mkHsWrap wrap id_expr, rho) } +tcInferIdWithOrig orig id_name = + do { id_level <- getIdLevel id_name + ; cur_level <- getHetMetLevel + ; if (length id_level < length cur_level) + then do { (lhexp, tcrho) <- + tcInferRho (noLoc $ addEscapes (take ((length cur_level) - (length id_level)) cur_level) (HsVar id_name)) + ; return (unLoc lhexp, tcrho) + } + else tcInferIdWithOrig' orig id_name + } + +tcInferIdWithOrig' orig id_name = + do { id <- lookup_id + ; (id_expr, id_rho) <- instantiateOuter orig id + ; (wrap, rho) <- deeplyInstantiate orig id_rho + ; return (mkHsWrap wrap id_expr, rho) } where lookup_id :: TcM TcId lookup_id = do { thing <- tcLookup id_name ; case thing of - ATcId { tct_id = id, tct_level = lvl } + ATcId { tct_id = id, tct_level = lvl, tct_hetMetLevel = variable_hetMetLevel } -> do { check_naughty id -- Note [Local record selectors] ; checkThLocalId id lvl + ; current_hetMetLevel <- getHetMetLevel + ; mapM + (\(name1,name2) -> unifyType (TyVarTy name1) (TyVarTy name2)) + (zip variable_hetMetLevel current_hetMetLevel) ; return id } AGlobal (AnId id) - -> do { check_naughty id; return id } - -- A global cannot possibly be ill-staged + -> do { check_naughty id + ; return id } + -- A global cannot possibly be ill-staged in Template Haskell -- nor does it need the 'lifting' treatment -- hence no checkTh stuff here diff --combined compiler/typecheck/TcHsSyn.lhs index 4f2eda7,122b743..ab7d8c2 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@@ -269,15 -269,16 +269,16 @@@ zonkTopLExpr e = zonkLExpr emptyZonkEn zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet - -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM ([Id], - Bag EvBind, - Bag (LHsBind Id), - [LForeignDecl Id], - [LTcSpecPrag], - [LRuleDecl Id]) - zonkTopDecls ev_binds binds sig_ns rules imp_specs fords - = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> TcM ([Id], + Bag EvBind, + Bag (LHsBind Id), + [LForeignDecl Id], + [LTcSpecPrag], + [LRuleDecl Id], + [LVectDecl Id]) + zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds -- Warn about missing signatures -- Do this only when we we have a type to offer @@@ -286,11 -287,12 +287,12 @@@ | otherwise = noSigWarn ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; vects' <- zonkVects env2 vects ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@@ -542,22 -544,6 +544,22 @@@ zonkExpr env (HsPar e = zonkLExpr env e `thenM` \new_e -> returnM (HsPar new_e) +zonkExpr env (HsHetMetBrak c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetBrak c' e') + +zonkExpr env (HsHetMetEsc c t e) + = do c' <- zonkTcTypeToType env c + t' <- zonkTcTypeToType env t + e' <- zonkLExpr env e + return (HsHetMetEsc c' t' e') + +zonkExpr env (HsHetMetCSP c e) + = do c' <- zonkTcTypeToType env c + e' <- zonkLExpr env e + return (HsHetMetCSP c' e') + zonkExpr env (SectionL expr op) = zonkLExpr env expr `thenM` \ new_expr -> zonkLExpr env op `thenM` \ new_op -> @@@ -1022,6 -1008,21 +1024,21 @@@ zonkRule env (HsRule name act (vars{-:: | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} + \begin{code} + zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] + zonkVects env = mappM (wrapLocM (zonkVect env)) + + zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) + zonkVect env (HsVect v Nothing) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsVect v' Nothing + } + zonkVect env (HsVect v (Just e)) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; e' <- zonkLExpr env e + ; return $ HsVect v' (Just e') + } + \end{code} %************************************************************************ %* * diff --combined compiler/typecheck/TcRnMonad.lhs index 1d5a3f7,ad2405b..deefe93 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@@ -114,11 -114,12 +114,12 @@@ initTc hsc_env hsc_src keep_rn_syntax m tcg_warns = NoWarnings, tcg_anns = [], tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, tcg_doc_hdr = Nothing, tcg_hpc = False, tcg_main = Nothing @@@ -134,8 -135,7 +135,8 @@@ tcl_tyvars = tvs_var, tcl_lie = lie_var, tcl_meta = meta_var, - tcl_untch = initTyVarUnique + tcl_untch = initTyVarUnique, + tcl_hetMetLevel = [] } ; } ; diff --combined compiler/typecheck/TcRnTypes.lhs index eee07e8,3367f06..ada8180 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@@ -260,9 -260,10 +260,10 @@@ data TcGblEn tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_insts :: [Instance], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the @@@ -372,7 -373,6 +373,7 @@@ data TcLclEnv -- Changes as we move in -- We still need the unsullied global name env so that -- we can look up record field names + tcl_hetMetLevel :: [TyVar], -- The current environment classifier level (list-of-names) tcl_env :: TcTypeEnv, -- The local type environment: Ids and -- TyVars defined in this module @@@ -509,9 -509,7 +510,9 @@@ data TcTyThin | ATcId { -- Ids defined in this module; may not be fully zonked tct_id :: TcId, - tct_level :: ThLevel } + tct_level :: ThLevel, + tct_hetMetLevel :: [TyVar] + } | ATyVar Name TcType -- The type to which the lexically scoped type vaiable -- is currently refined. We only need the Name @@@ -526,8 -524,7 +527,8 @@@ instance Outputable TcTyThing where -- ppr elt@(ATcId {}) = text "Identifier" <> brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma - <+> ppr (tct_level elt)) + <+> ppr (tct_level elt) + <+> ppr (tct_hetMetLevel elt)) ppr (ATyVar tv _) = text "Type variable" <+> quotes (ppr tv) ppr (AThing k) = text "AThing" <+> ppr k @@@ -718,10 -715,10 +719,10 @@@ andWC (WC { wc_flat = f1, wc_impl = i1 , wc_insol = n1 `unionBags` n2 } addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints - addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc } + addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs } addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints - addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc } + addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) @@@ -887,11 -884,12 +888,12 @@@ wantedToFlavored (EvVarX v wl) = EvVar keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar keepWanted flevs - = foldlBag keep_wanted emptyBag flevs + = foldrBag keep_wanted emptyBag flevs + -- Important: use fold*r*Bag to preserve the order of the evidence variables. where - keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar - keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r - keep_wanted r _ = r + keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar + keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r + keep_wanted _ r = r \end{code} @@@ -939,10 -937,9 +941,9 @@@ data CtFlavo -- superclasses. instance Outputable CtFlavor where - ppr (Given _) = ptext (sLit "[Given]") - ppr (Wanted _) = ptext (sLit "[Wanted]") - ppr (Derived {}) = ptext (sLit "[Derived]") - + ppr (Given {}) = ptext (sLit "[G]") + ppr (Wanted {}) = ptext (sLit "[W]") + ppr (Derived {}) = ptext (sLit "[D]") pprFlavorArising :: CtFlavor -> SDoc pprFlavorArising (Derived wl ) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl