From: Adam Megacz <megacz@cs.berkeley.edu>
Date: Tue, 14 Jun 2011 18:50:10 +0000 (-0700)
Subject: merge upstream
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=7e95df790b34e11d7308e43dab0a7175b69b70fc;hp=-c

merge upstream
---

7e95df790b34e11d7308e43dab0a7175b69b70fc
diff --combined compiler/basicTypes/Name.lhs
index aac7670,a2b42a2..6153637
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@@ -64,7 -64,6 +64,7 @@@ module Name 
  	getSrcLoc, getSrcSpan, getOccString,
  
   	pprInfixName, pprPrefixName, pprModulePrefix,
 +        getNameDepth, setNameDepth,
  
  	-- Re-export the OccName stuff
  	module OccName
@@@ -113,12 -112,6 +113,12 @@@ data Name = Name 
  -- (and real!) space leaks, due to the fact that we don't look at
  -- the SrcLoc in a Name all that often.
  
 +setNameDepth :: Int -> Name -> Name
 +setNameDepth depth name = name { n_occ = setOccNameDepth depth (n_occ name) }
 +
 +getNameDepth :: Name -> Int
 +getNameDepth name = getOccNameDepth $ n_occ name
 +
  data NameSort
    = External Module
   
@@@ -487,12 -480,14 +487,14 @@@ ppr_z_occ_name occ = ftext (zEncodeFS (
  -- Prints (if mod information is available) "Defined at <loc>" or 
  --  "Defined in <mod>" information for a Name.
  pprNameLoc :: Name -> SDoc
- pprNameLoc name
-   | isGoodSrcSpan loc = pprDefnLoc loc
-   | isInternalName name || isSystemName name 
-                       = ptext (sLit "<no location info>")
-   | otherwise         = ptext (sLit "Defined in ") <> ppr (nameModule name)
-   where loc = nameSrcSpan name
+ pprNameLoc name = case nameSrcSpan name of
+                   RealSrcSpan s ->
+                       pprDefnLoc s
+                   UnhelpfulSpan _
+                    | isInternalName name || isSystemName name ->
+                       ptext (sLit "<no location info>")
+                    | otherwise ->
+                       ptext (sLit "Defined in ") <> ppr (nameModule name)
  \end{code}
  
  %************************************************************************
diff --combined compiler/deSugar/Desugar.lhs
index 2e51823,af2db36..9b48cce
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@@ -15,11 -15,9 +15,11 @@@ import HsSy
  import TcRnTypes
  import MkIface
  import Id
 +import Pair
  import Name
  import CoreSyn
  import CoreSubst
 +import CoqPass ( coqPassCoreToString, coqPassCoreToCore )
  import PprCore
  import DsMonad
  import DsExpr
@@@ -42,12 -40,6 +42,12 @@@ import MonadUtil
  import OrdList
  import Data.List
  import Data.IORef
 +import PrelNames
 +import UniqSupply
 +import UniqFM
 +import CoreFVs
 +import Type
 +import Coercion
  \end{code}
  
  %************************************************************************
@@@ -57,7 -49,6 +57,7 @@@
  %************************************************************************
  
  \begin{code}
 +
  -- | Main entry point to the desugarer.
  deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
  -- Can modify PCS by faulting in more declarations
@@@ -98,34 -89,7 +98,34 @@@ deSugar hsc_en
                <- case target of
  	           HscNothing ->
                         return (emptyMessages,
 -                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks))
 +                               Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks, undefined, undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                                    , undefined
 +                               ))
                     _        -> do
                       (binds_cvr,ds_hpc_info, modBreaks)
  			 <- if (opt_Hpc
@@@ -141,34 -105,6 +141,34 @@@
                            ; (ds_fords, foreign_prs) <- dsForeigns fords
                            ; ds_rules <- mapMaybeM dsRule rules
                            ; ds_vects <- mapM dsVect vects
 +                          ; hetmet_brak <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_brak_name else return undefined
 +                          ; hetmet_esc  <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_esc_name  else return undefined
 +                          ; hetmet_flatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flatten_name else return undefined
 +                          ; hetmet_unflatten <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_unflatten_name else return undefined
 +                          ; hetmet_flattened_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_flattened_id_name else return undefined
 +                          ; hetmet_PGArrow <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_name else return undefined
 +                          ; hetmet_PGArrow_unit <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_unit_name else return undefined
 +                          ; hetmet_PGArrow_tensor <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_tensor_name else return undefined
 +                          ; hetmet_PGArrow_exponent <- if dopt Opt_F_coqpass dflags then dsLookupTyCon hetmet_PGArrow_exponent_name else return undefined
 +                          ; hetmet_pga_id <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_id_name else return undefined
 +                          ; hetmet_pga_comp <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_comp_name else return undefined
 +                          ; hetmet_pga_first <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_first_name else return undefined
 +                          ; hetmet_pga_second <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_second_name else return undefined
 +                          ; hetmet_pga_cancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancell_name else return undefined
 +                          ; hetmet_pga_cancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_cancelr_name else return undefined
 +                          ; hetmet_pga_uncancell <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancell_name else return undefined
 +                          ; hetmet_pga_uncancelr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_uncancelr_name else return undefined
 +                          ; hetmet_pga_assoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_assoc_name else return undefined
 +                          ; hetmet_pga_unassoc <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_unassoc_name else return undefined
 +                          ; hetmet_pga_copy <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_copy_name else return undefined
 +                          ; hetmet_pga_drop <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_drop_name else return undefined
 +                          ; hetmet_pga_swap <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_swap_name else return undefined
 +                          ; hetmet_pga_applyl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyl_name else return undefined
 +                          ; hetmet_pga_applyr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_applyr_name else return undefined
 +                          ; hetmet_pga_curryl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryl_name else return undefined
 +                          ; hetmet_pga_curryr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_curryr_name else return undefined
 +                          ; hetmet_pga_loopl <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopl_name else return undefined
 +                          ; hetmet_pga_loopr <- if dopt Opt_F_coqpass dflags then dsLookupGlobalId hetmet_pga_loopr_name else return undefined
                            ; let hpc_init
                                    | opt_Hpc   = hpcInitCode mod ds_hpc_info
                                    | otherwise = empty
@@@ -176,148 -112,40 +176,148 @@@
                                     , foreign_prs `appOL` core_prs `appOL` spec_prs
                                     , spec_rules ++ ds_rules, ds_vects
                                     , ds_fords `appendStubC` hpc_init
 -                                   , ds_hpc_info, modBreaks) }
 +                                   , ds_hpc_info, modBreaks, hetmet_brak, hetmet_esc
 +                                   , hetmet_flatten
 +                                   , hetmet_unflatten
 +                                   , hetmet_flattened_id
 +                                   , hetmet_PGArrow
 +                                   , hetmet_PGArrow_unit
 +                                   , hetmet_PGArrow_tensor
 +                                   , hetmet_PGArrow_exponent
 +                                   , hetmet_pga_id
 +                                   , hetmet_pga_comp
 +                                   , hetmet_pga_first
 +                                   , hetmet_pga_second
 +                                   , hetmet_pga_cancell
 +                                   , hetmet_pga_cancelr
 +                                   , hetmet_pga_uncancell
 +                                   , hetmet_pga_uncancelr
 +                                   , hetmet_pga_assoc
 +                                   , hetmet_pga_unassoc
 +                                   , hetmet_pga_copy
 +                                   , hetmet_pga_drop
 +                                   , hetmet_pga_swap
 +                                   , hetmet_pga_applyl
 +                                   , hetmet_pga_applyr
 +                                   , hetmet_pga_curryl
 +                                   , hetmet_pga_curryr
 +                                   , hetmet_pga_loopl
 +                                   , hetmet_pga_loopr
 +                                   ) }
  
          ; case mb_res of {
             Nothing -> return (msgs, Nothing) ;
-            Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks
 -           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
++           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks
 +                                   , hetmet_brak, hetmet_esc
 +                                   , hetmet_flatten
 +                                   , hetmet_unflatten
 +                                   , hetmet_flattened_id
 +                                   , hetmet_PGArrow
 +                                   , hetmet_PGArrow_unit
 +                                   , hetmet_PGArrow_tensor
 +                                   , hetmet_PGArrow_exponent
 +                                   , hetmet_pga_id
 +                                   , hetmet_pga_comp
 +                                   , hetmet_pga_first
 +                                   , hetmet_pga_second
 +                                   , hetmet_pga_cancell
 +                                   , hetmet_pga_cancelr
 +                                   , hetmet_pga_uncancell
 +                                   , hetmet_pga_uncancelr
 +                                   , hetmet_pga_assoc
 +                                   , hetmet_pga_unassoc
 +                                   , hetmet_pga_copy
 +                                   , hetmet_pga_drop
 +                                   , hetmet_pga_swap
 +                                   , hetmet_pga_applyl
 +                                   , hetmet_pga_applyr
 +                                   , hetmet_pga_curryl
 +                                   , hetmet_pga_curryr
 +                                   , hetmet_pga_loopl
 +                                   , hetmet_pga_loopr
 +                                   ) -> do
  
- 	{ 	-- Add export flags to bindings
- 	  keep_alive <- readIORef keep_var
- 	; let (rules_for_locals, rules_for_imps) 
+         {       -- Add export flags to bindings
+           keep_alive <- readIORef keep_var
+         ; let (rules_for_locals, rules_for_imps) 
                     = partition isLocalRule all_rules
                final_prs = addExportFlagsAndRules target
- 	      		      export_set keep_alive rules_for_locals (fromOL all_prs)
+                               export_set keep_alive rules_for_locals (fromOL all_prs)
  
 -              final_pgm = combineEvBinds ds_ev_binds final_prs
 +              final_pgm = let comb = combineEvBinds ds_ev_binds final_prs
 +                          in if dopt Opt_F_simpleopt_before_flatten dflags
 +                             then comb
 +                             else simplifyBinds comb
- 	-- Notice that we put the whole lot in a big Rec, even the foreign binds
- 	-- When compiling PrelFloat, which defines data Float = F# Float#
- 	-- we want F# to be in scope in the foreign marshalling code!
- 	-- You might think it doesn't matter, but the simplifier brings all top-level
- 	-- things into the in-scope set before simplifying; so we get no unfolding for F#!
- 
- 	-- Lint result if necessary, and print
-         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
-                (vcat [ pprCoreBindings final_pgm
-                      , pprRules rules_for_imps ])
+         -- Notice that we put the whole lot in a big Rec, even the foreign binds
+         -- When compiling PrelFloat, which defines data Float = F# Float#
+         -- we want F# to be in scope in the foreign marshalling code!
+         -- You might think it doesn't matter, but the simplifier brings all top-level
+         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
  
 -        -- Lint result if necessary, and print
 -        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
 -               (vcat [ pprCoreBindings final_pgm
 -                     , pprRules rules_for_imps ])
 +	; (final_pgm', rules_for_imps') <- if dopt Opt_F_simpleopt_before_flatten dflags
 +                                            then simpleOptPgm dflags final_pgm rules_for_imps
 +                                            else return (final_pgm, rules_for_imps)
 +
 +        ; ds_binds <- if dopt Opt_F_coqpass dflags
 +                       then do { us <- mkSplitUniqSupply '~'
 +                               ; let do_flatten   = dopt Opt_F_flatten dflags
 +                               ; let do_skolemize = dopt Opt_F_skolemize dflags
 +                               ; return (coqPassCoreToCore
 +                                             do_flatten
 +                                             do_skolemize
 +                                             hetmet_brak
 +                                             hetmet_esc
 +                                             hetmet_flatten
 +                                             hetmet_unflatten
 +                                             hetmet_flattened_id
 +                                             us
 +                                             final_pgm'
 +                                             hetmet_PGArrow
 +                                             hetmet_PGArrow_unit
 +                                             hetmet_PGArrow_tensor
 +                                             hetmet_PGArrow_exponent
 +                                             hetmet_pga_id
 +                                             hetmet_pga_comp
 +                                             hetmet_pga_first
 +                                             hetmet_pga_second
 +                                             hetmet_pga_cancell
 +                                             hetmet_pga_cancelr
 +                                             hetmet_pga_uncancell
 +                                             hetmet_pga_uncancelr
 +                                             hetmet_pga_assoc
 +                                             hetmet_pga_unassoc
 +                                             hetmet_pga_copy
 +                                             hetmet_pga_drop
 +                                             hetmet_pga_swap
 +                                             hetmet_pga_applyl
 +                                             hetmet_pga_applyr
 +                                             hetmet_pga_curryl
 +                                             hetmet_pga_curryr
 +                                             hetmet_pga_loopl
 +                                             hetmet_pga_loopr
 +                                        )
 +                               }
 +                       else return final_pgm
 +
 +	; (ds_binds', ds_rules_for_imps) <- if dopt Opt_F_simpleopt_before_flatten dflags
 +                                            then return (ds_binds, rules_for_imps')
 +                                            else simpleOptPgm dflags ds_binds rules_for_imps'
 +	      		 -- The simpleOptPgm gets rid of type 
 +			 -- bindings plus any stupid dead code
 +
 +        ; dumpIfSet_dyn dflags Opt_D_dump_proofs "Coq Pass Output" $ text $ coqPassCoreToString ds_binds'
 +
 +        ; dumpIfSet_dyn dflags Opt_D_coqpass "After Coq Pass" (text $ showSDoc $ pprCoreBindings ds_binds')
  
- 	; endPass dflags CoreDesugar ds_binds' ds_rules_for_imps
+         ; (ds_binds, ds_rules_for_imps, ds_vects) 
+             <- simpleOptPgm dflags final_pgm rules_for_imps vects0
+                          -- The simpleOptPgm gets rid of type 
+                          -- bindings plus any stupid dead code
+ 
+         ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
  
          ; let used_names = mkUsedNames tcg_env
- 	; deps <- mkDependencies tcg_env
+         ; deps <- mkDependencies tcg_env
  
          ; let mod_guts = ModGuts {	
  		mg_module    	= mod,
@@@ -336,7 -164,7 +336,7 @@@
  		mg_inst_env     = inst_env,
  		mg_fam_inst_env = fam_inst_env,
  	        mg_rules     	= ds_rules_for_imps,
 -		mg_binds     	= ds_binds,
 +		mg_binds     	= ds_binds',
  		mg_foreign   	= ds_fords,
  		mg_hpc_info  	= ds_hpc_info,
                  mg_modBreaks    = modBreaks,
@@@ -566,49 -394,11 +566,44 @@@ the rule is precisly to optimise them
  
  \begin{code}
  dsVect :: LVectDecl Id -> DsM CoreVect
- dsVect (L loc (HsVect v rhs))
+ dsVect (L loc (HsVect (L _ v) rhs))
    = putSrcSpanDs loc $ 
      do { rhs' <- fmapMaybeM dsLExpr rhs
-        ; return $ Vect (unLoc v) rhs'
+        ; return $ Vect 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')
- --       }
+ dsVect (L _loc (HsNoVect (L _ v)))
+   = return $ NoVect v
  \end{code}
 +
 +
 +
 +\begin{code}
 +--
 +-- Simplification routines run before the flattener.  We can't use
 +-- simpleOptPgm -- it doesn't preserve the order of subexpressions or
 +-- let-binding groups.
 +--
 +simplify :: Expr CoreBndr -> Expr CoreBndr
 +simplify (Var v)                 = Var v
 +simplify (App e1 e2)             = App (simplify e1) (simplify e2)
 +simplify (Lit lit)               = Lit lit
 +simplify (Note note e)           = Note note (simplify e)
 +simplify (Cast e co)             = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co)
 +                                       then simplify e
 +                                       else Cast (simplify e) co
 +simplify (Lam v e)               = Lam v (simplify e)
 +simplify (Case e b ty as)        = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as)
 +simplify (Let bind body)         = foldr Let (simplify body) (simplifyBind bind)
 +simplify (Type t)                = Type t
 +simplify (Coercion co)           = Coercion co
 +
 +simplifyBind :: Bind CoreBndr -> [Bind CoreBndr]
 +simplifyBind (NonRec b e)             = [NonRec b (simplify e)]
 +simplifyBind (Rec [])                 = []
 +simplifyBind (Rec (rbs@((b,e):rbs'))) =
 +    if or $ map (\x -> elemUFM x (exprFreeIds e)) (map fst rbs)
 +    then [Rec (map (\(v,e) -> (v,simplify e)) rbs)]
 +    else (NonRec b (simplify e)):(simplifyBind $ Rec rbs')
 +
 +simplifyBinds = concatMap simplifyBind
 +\end{code}
diff --combined compiler/ghc.cabal.in
index 8a98775,4ffb9156..c4be998
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@@ -182,7 -182,7 +182,7 @@@ Librar
          CLabel
          Cmm
          CmmBuildInfoTables
-         CmmCPS
+         CmmPipeline
          CmmCallConv
          CmmCommonBlockElim
          CmmContFlowOpt
@@@ -199,6 -199,7 +199,7 @@@
          CmmParse
          CmmProcPoint
          CmmSpillReload
+         CmmRewriteAssignments
          CmmStackLayout
          CmmType
          CmmUtils
@@@ -261,7 -262,6 +262,7 @@@
          CoreTidy
          CoreUnfold
          CoreUtils
 +        CoqPass
          ExternalCore
          MkCore
          MkExternalCore
diff --combined compiler/hsSyn/HsTypes.lhs
index 7159540,d565c96..75e6c23
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@@ -26,6 -26,7 +26,7 @@@ module HsTypes 
  	hsTyVarKind, hsTyVarNameKind,
  	hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
  	splitHsInstDeclTy, splitHsFunType,
+ 	splitHsAppTys, mkHsAppTys,
  	
  	-- Type place holder
  	PostTcType, placeHolderType, PostTcKind, placeHolderKind,
@@@ -155,8 -156,6 +156,8 @@@ data HsType nam
  
    | HsPArrTy		(LHsType name)	-- Elem. type of parallel array: [:t:]
  
 +  | HsModalBoxType	name (LHsType name)	-- modal types; first argument is the environment classifier
 +
    | HsTupleTy		Boxity
  			[LHsType name]	-- Element types (length gives arity)
  
@@@ -294,6 -293,19 +295,19 @@@ replaceTyVarName (KindedTyVar _ k) n' 
  
  
  \begin{code}
+ splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
+ splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as)
+ splitHsAppTys f          	  as = (f,as)
+ 
+ mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n
+ mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
+ mkHsAppTys fun_ty (arg_ty:arg_tys)
+   = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
+   where
+     mk_app fun arg = HsAppTy (noLoc fun) arg	
+        -- Add noLocs for inner nodes of the application; 
+        -- they are never used 
+ 
  splitHsInstDeclTy 
      :: OutputableBndr name
      => HsType name 
@@@ -439,7 -451,6 +453,7 @@@ ppr_mono_ty _    (HsTupleTy con tys) = 
  ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
  ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
  ppr_mono_ty _    (HsPArrTy ty)	     = pabrackets (ppr_mono_lty pREC_TOP ty)
 +ppr_mono_ty _    (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
  ppr_mono_ty _    (HsPredTy pred)     = ppr pred
  ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
  ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
@@@ -476,10 -487,6 +490,10 @@@ ppr_fun_ty ctxt_prec ty1 ty
  --------------------------
  pabrackets :: SDoc -> SDoc
  pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
 +
 +ppr_modalBoxType :: SDoc -> SDoc -> SDoc
 +ppr_modalBoxType ecn p = ptext (sLit "<[") <> p <> ptext (sLit "]>@") <> ecn 
 +
  \end{code}
  
  
diff --combined compiler/iface/BinIface.hs
index b3de3f4,502eefa..b9ad5c8
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@@ -1301,14 -1301,10 +1301,14 @@@ instance Binary IfaceNote wher
  -- to avoid re-building it in various places.  So we build the OccName
  -- when de-serialising.
  
 +-- NOTE regarding HetMet extensions: this screws up Adam's heinous
 +-- hide-the-syntactical-level-in-the-namespace trick.
 +
  instance Binary IfaceDecl where
      put_ bh (IfaceId name ty details idinfo) = do
  	    putByte bh 0
  	    put_ bh (occNameFS name)
 +	    put_ bh (getOccNameDepth name)
  	    put_ bh ty
  	    put_ bh details
  	    put_ bh idinfo
@@@ -1343,11 -1339,10 +1343,11 @@@
  	    h <- getByte bh
  	    case h of
  	      0 -> do name    <- get bh
 +		      depth   <- get bh
  		      ty      <- get bh
  		      details <- get bh
  		      idinfo  <- get bh
 -                      occ <- return $! mkOccNameFS varName name
 +                      occ <- return $! mkOccNameFS (varNameDepth depth) name
  		      return (IfaceId occ ty details idinfo)
  	      1 -> error "Binary.get(TyClDecl): ForeignType"
  	      2 -> do
@@@ -1458,15 -1453,13 +1458,15 @@@ instance Binary IfaceConDecl wher
  instance Binary IfaceClassOp where
     put_ bh (IfaceClassOp n def ty) = do	
  	put_ bh (occNameFS n)
 +	put_ bh (getOccNameDepth n)
  	put_ bh def	
  	put_ bh ty
     get bh = do
  	n <- get bh
 +	depth <- get bh
  	def <- get bh
  	ty <- get bh
 -        occ <- return $! mkOccNameFS varName n
 +        occ <- return $! mkOccNameFS (varNameDepth depth) n
  	return (IfaceClassOp occ def ty)
  
  instance Binary IfaceRule where
@@@ -1515,14 -1508,18 +1515,18 @@@ instance Binary name => Binary (AnnTarg
                    return (ModuleTarget a)
  
  instance Binary IfaceVectInfo where
-     put_ bh (IfaceVectInfo a1 a2 a3) = do
+     put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
  	    put_ bh a1
  	    put_ bh a2
  	    put_ bh a3
+ 	    put_ bh a4
+ 	    put_ bh a5
      get bh = do
  	    a1 <- get bh
  	    a2 <- get bh
  	    a3 <- get bh
- 	    return (IfaceVectInfo a1 a2 a3)
+ 	    a4 <- get bh
+ 	    a5 <- get bh
+ 	    return (IfaceVectInfo a1 a2 a3 a4 a5)
  
  
diff --combined compiler/iface/TcIface.lhs
index f29bf85,5bfb406..c2cb33f
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@@ -39,14 -39,16 +39,16 @@@ import Clas
  import TyCon
  import DataCon
  import TysWiredIn
- import TysPrim		( anyTyConOfKind )
- import BasicTypes	( Arity, nonRuleLoopBreaker )
+ import TysPrim          ( anyTyConOfKind )
+ import BasicTypes       ( Arity, nonRuleLoopBreaker )
  import qualified Var
  import VarEnv
+ import VarSet
  import Name
  import NameEnv
- import OccurAnal	( occurAnalyseExpr )
- import Demand		( isBottomingSig )
+ import NameSet
+ import OccurAnal        ( occurAnalyseExpr )
+ import Demand           ( isBottomingSig )
  import Module
  import UniqFM
  import UniqSupply
@@@ -144,7 -146,7 +146,7 @@@ importDecl nam
    where
      nd_doc = ptext (sLit "Need decl for") <+> ppr name
      not_found_msg = hang (ptext (sLit "Can't find interface-file declaration for") <+>
 -				pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
 +				pprNameSpace (occNameSpace (nameOccName name)) <+> (ppr (nameOccName name)))
  	  	       2 (vcat [ptext (sLit "Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
  		                ptext (sLit "Use -ddump-if-trace to get an idea of which file caused the error")])
  \end{code}
@@@ -689,28 -691,32 +691,32 @@@ tcIfaceAnnTarget (ModuleTarget mod) = d
  
  
  %************************************************************************
- %*									*
- 		Vectorisation information
- %*									*
+ %*                                                                      *
+                 Vectorisation information
+ %*                                                                      *
  %************************************************************************
  
  \begin{code}
  tcIfaceVectInfo :: Module -> TypeEnv  -> IfaceVectInfo -> IfL VectInfo
  tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
-                              { ifaceVectInfoVar        = vars
-                              , ifaceVectInfoTyCon      = tycons
-                              , ifaceVectInfoTyConReuse = tyconsReuse
+                              { ifaceVectInfoVar          = vars
+                              , ifaceVectInfoTyCon        = tycons
+                              , ifaceVectInfoTyConReuse   = tyconsReuse
+                              , ifaceVectInfoScalarVars   = scalarVars
+                              , ifaceVectInfoScalarTyCons = scalarTyCons
                               })
    = do { vVars     <- mapM vectVarMapping vars
         ; tyConRes1 <- mapM vectTyConMapping      tycons
         ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse
         ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2)
         ; return $ VectInfo 
-                   { vectInfoVar     = mkVarEnv  vVars
-                   , vectInfoTyCon   = mkNameEnv vTyCons
-                   , vectInfoDataCon = mkNameEnv (concat vDataCons)
-                   , vectInfoPADFun  = mkNameEnv vPAs
-                   , vectInfoIso     = mkNameEnv vIsos
+                   { vectInfoVar          = mkVarEnv     vVars
+                   , vectInfoTyCon        = mkNameEnv    vTyCons
+                   , vectInfoDataCon      = mkNameEnv    (concat vDataCons)
+                   , vectInfoPADFun       = mkNameEnv    vPAs
+                   , vectInfoIso          = mkNameEnv    vIsos
+                   , vectInfoScalarVars   = mkVarSet  (map lookupVar scalarVars)
+                   , vectInfoScalarTyCons = mkNameSet scalarTyCons
                    }
         }
    where
@@@ -778,9 -784,9 +784,9 @@@
  \end{code}
  
  %************************************************************************
- %*									*
- 			Types
- %*									*
+ %*                                                                      *
+                         Types
+ %*                                                                      *
  %************************************************************************
  
  \begin{code}
diff --combined compiler/main/DynFlags.hs
index 7e5dff0,b49b860..e5bd677
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@@ -204,13 -204,6 +204,13 @@@ data DynFla
     | Opt_DoCmmLinting
     | Opt_DoAsmLinting
  
 +   | Opt_F_coqpass                      -- run the core-to-core coqPass, but don't change anything (just "parse/unparse")
 +   | Opt_F_skolemize                    -- run the core-to-core coqPass, skolemizing the proof
 +   | Opt_F_flatten                      -- run the core-to-core coqPass, flattening the proof
 +   | Opt_F_simpleopt_before_flatten     -- run the "simplPgmOpt" before the coqPass
 +   | Opt_D_dump_proofs                  -- dump natural deduction typing proof of the coqpass input
 +   | Opt_D_coqpass                      -- run the core-to-string coqPass and dumps the result
 +
     | Opt_WarnIsError                    -- -Werror; makes warnings fatal
     | Opt_WarnDuplicateExports
     | Opt_WarnHiShadows
@@@ -340,7 -333,6 +340,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
@@@ -652,7 -644,6 +652,6 @@@ data HscTarge
    = HscC           -- ^ Generate C code.
    | HscAsm         -- ^ Generate assembly using the native code generator.
    | HscLlvm        -- ^ Generate assembly using the llvm code generator.
-   | HscJava        -- ^ Generate Java bytecode.
    | HscInterpreted -- ^ Generate bytecode.  (Requires 'LinkInMemory')
    | HscNothing     -- ^ Don't generate any code.  See notes above.
    deriving (Eq, Show)
@@@ -661,7 -652,6 +660,6 @@@ showHscTargetFlag :: HscTarget -> Strin
  showHscTargetFlag HscC           = "-fvia-c"
  showHscTargetFlag HscAsm         = "-fasm"
  showHscTargetFlag HscLlvm        = "-fllvm"
- showHscTargetFlag HscJava        = panic "No flag for HscJava"
  showHscTargetFlag HscInterpreted = "-fbyte-code"
  showHscTargetFlag HscNothing     = "-fno-code"
  
@@@ -1372,14 -1362,6 +1370,14 @@@ dynamic_flags = 
                                                setVerbosity (Just 2)))
    , Flag "dfaststring-stats"       (NoArg (setDynFlag Opt_D_faststring_stats))
  
 +        ------ Coq-in-GHC ---------------------------
 +  , Flag "ddump-proofs"            (NoArg (setDynFlag Opt_D_dump_proofs))
 +  , Flag "ddump-coqpass"           (NoArg (setDynFlag Opt_D_coqpass))
 +  , Flag "fcoqpass"                (NoArg (setDynFlag Opt_F_coqpass))
 +  , Flag "fsimpleopt-before-flatten"                (NoArg (setDynFlag Opt_F_simpleopt_before_flatten))
 +  , Flag "fflatten"                (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten }))
 +  , Flag "funsafe-skolemize"       (NoArg (do { setDynFlag Opt_F_coqpass ; setDynFlag Opt_F_flatten ; setDynFlag Opt_F_skolemize }))
 +
          ------ Machine dependant (-m<blah>) stuff ---------------------------
  
    , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release"))
@@@ -1681,7 -1663,6 +1679,7 @@@ xFlags = 
      deprecatedForExtension "DoRec"),
    ( "DoRec",                            Opt_DoRec, nop ),    -- Enables 'rec' keyword 
    ( "Arrows",                           Opt_Arrows, nop ),
 +  ( "ModalTypes",			Opt_ModalTypes, nop ),
    ( "ParallelArrays",                   Opt_ParallelArrays, nop ),
    ( "TemplateHaskell",                  Opt_TemplateHaskell, checkTemplateHaskellOk ),
    ( "QuasiQuotes",                      Opt_QuasiQuotes, nop ),
@@@ -1777,11 -1758,6 +1775,11 @@@ impliedFlag
      , (Opt_FlexibleInstances,         turnOn, Opt_TypeSynonymInstances)
      , (Opt_FunctionalDependencies,    turnOn, Opt_MultiParamTypeClasses)
  
 +    , (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)
diff --combined compiler/parser/Lexer.x
index 4ca0282,43a4004..c9b2e1c
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@@ -7,7 -7,8 +7,8 @@@
  -- definition, with some hand-coded bits.
  --
  -- Completely accurate information about token-spans within the source
- -- file is maintained.  Every token has a start and end SrcLoc attached to it.
+ -- file is maintained.  Every token has a start and end RealSrcLoc
+ -- attached to it.
  --
  -----------------------------------------------------------------------------
  
@@@ -55,7 -56,6 +56,7 @@@ module Lexer 
     getLexState, popLexState, pushLexState,
     extension, bangPatEnabled, datatypeContextsEnabled,
     addWarning,
 +   incrBracketDepth, decrBracketDepth, getParserBrakDepth,
     lexTokenStream
    ) where
  
@@@ -326,15 -326,6 +327,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 }
  }
  
@@@ -492,6 -483,7 +493,7 @@@ data Toke
    | ITlanguage_prag
    | ITvect_prag
    | ITvect_scalar_prag
+   | ITnovect_prag
  
    | ITdotdot  			-- reserved symbols
    | ITcolon
@@@ -565,7 -557,7 +567,7 @@@
    | ITparenEscape		--  $( 
    | ITvarQuote			--  '
    | ITtyQuote			--  ''
-   | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
+   | ITquasiQuote (FastString,FastString,RealSrcSpan) --  [:...|...|]
  
    -- Arrow notation extension
    | ITproc
@@@ -577,13 -569,6 +579,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
  
@@@ -738,7 -723,7 +740,7 @@@ reservedSymsFM = listToUFM 
  -- -----------------------------------------------------------------------------
  -- Lexer actions
  
- type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
+ type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
  
  special :: Token -> Action
  special tok span _buf _len = return (L span tok)
@@@ -781,7 -766,7 +783,7 @@@ hopefully_open_brace span buf le
                   Layout prev_off : _ -> prev_off < offset
                   _                   -> True
        if isOK then pop_and open_brace span buf len
-               else failSpanMsgP span (text "Missing block")
+               else failSpanMsgP (RealSrcSpan span) (text "Missing block")
  
  pop_and :: Action -> Action
  pop_and act span buf len = do _ <- popLexState
@@@ -863,7 -848,7 +865,7 @@@ lineCommentToken span buf len = d
    nested comments require traversing by hand, they can't be parsed
    using regular expressions.
  -}
- nested_comment :: P (Located Token) -> Action
+ nested_comment :: P (RealLocated Token) -> Action
  nested_comment cont span _str _len = do
    input <- getInput
    go "" (1::Int) input
@@@ -904,8 -889,8 +906,8 @@@ nested_doc_comment span buf _len = with
          Just (_,_) -> go ('\123':commentAcc) input docType False
        Just (c,input) -> go (c:commentAcc) input docType False
  
- withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
-                  -> P (Located Token)
+ withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
+                  -> P (RealLocated Token)
  withLexedDocType lexDocComment = do
    input@(AI _ buf) <- getInput
    case prevChar buf ' ' of
@@@ -942,19 -927,19 +944,19 @@@ endPrag span _buf _len = d
  -- called afterwards, so it can just update the state. 
  
  docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
-                  SrcSpan -> P (Located Token) 
+                  RealSrcSpan -> P (RealLocated Token) 
  docCommentEnd input commentAcc docType buf span = do
    setInput input
    let (AI loc nextBuf) = input
        comment = reverse commentAcc
-       span' = mkSrcSpan (srcSpanStart span) loc
+       span' = mkRealSrcSpan (realSrcSpanStart span) loc
        last_len = byteDiff buf nextBuf
        
    span `seq` setLastToken span' last_len
    return (L span' (docType comment))
   
- errBrace :: AlexInput -> SrcSpan -> P a
- errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
+ errBrace :: AlexInput -> RealSrcSpan -> P a
+ errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
  
  open_brace, close_brace :: Action
  open_brace span _str _len = do 
@@@ -1029,8 -1014,8 +1031,8 @@@ varsym, consym :: Actio
  varsym = sym ITvarsym
  consym = sym ITconsym
  
- sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
-     -> P (Located Token)
+ sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
+     -> P (RealLocated Token)
  sym con span buf len = 
    case lookupUFM reservedSymsFM fs of
  	Just (keyword,exts) -> do
@@@ -1162,7 -1147,7 +1164,7 @@@ do_layout_left span _buf _len = d
  setLine :: Int -> Action
  setLine code span buf len = do
    let line = parseUnsignedInteger buf len 10 octDecDigit
-   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+   setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
  	-- subtract one: the line number refers to the *following* line
    _ <- popLexState
    pushLexState code
@@@ -1171,12 -1156,17 +1173,17 @@@
  setFile :: Int -> Action
  setFile code span buf len = do
    let file = lexemeToFastString (stepOn buf) (len-2)
-   setAlrLastLoc noSrcSpan
-   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+   setAlrLastLoc $ alrInitialLoc file
+   setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
    _ <- popLexState
    pushLexState code
    lexToken
  
+ alrInitialLoc :: FastString -> RealSrcSpan
+ alrInitialLoc file = mkRealSrcSpan loc loc
+     where -- This is a hack to ensure that the first line in a file
+           -- looks like it is after the initial location:
+           loc = mkRealSrcLoc file (-1) (-1)
  
  -- -----------------------------------------------------------------------------
  -- Options, includes and language pragmas.
@@@ -1187,7 -1177,7 +1194,7 @@@ lex_string_prag mkTok span _buf _le
           start <- getSrcLoc
           tok <- go [] input
           end <- getSrcLoc
-          return (L (mkSrcSpan start end) tok)
+          return (L (mkRealSrcSpan start end) tok)
      where go acc input
                = if isString input "#-}"
                     then do setInput input
@@@ -1200,7 -1190,7 +1207,7 @@@
                = case alexGetChar i of
                    Just (c,i') | c == x    -> isString i' xs
                    _other -> False
-           err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
+           err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
  
  
  -- -----------------------------------------------------------------------------
@@@ -1212,7 -1202,7 +1219,7 @@@ lex_string_tok :: Actio
  lex_string_tok span _buf _len = do
    tok <- lex_string ""
    end <- getSrcLoc 
-   return (L (mkSrcSpan (srcSpanStart span) end) tok)
+   return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
  
  lex_string :: String -> P Token
  lex_string s = do
@@@ -1273,7 -1263,7 +1280,7 @@@ lex_char_tok :: Actio
  -- see if there's a trailing quote
  lex_char_tok span _buf _len = do	-- We've seen '
     i1 <- getInput	-- Look ahead to first character
-    let loc = srcSpanStart span
+    let loc = realSrcSpanStart span
     case alexGetChar' i1 of
  	Nothing -> lit_error  i1
  
@@@ -1281,7 -1271,7 +1288,7 @@@
  		  th_exts <- extension thEnabled
  		  if th_exts then do
  			setInput i2
- 			return (L (mkSrcSpan loc end2)  ITtyQuote)
+ 			return (L (mkRealSrcSpan loc end2)  ITtyQuote)
  		   else lit_error i1
  
  	Just ('\\', i2@(AI _end2 _)) -> do 	-- We've seen 'backslash
@@@ -1307,10 -1297,10 +1314,10 @@@
  					-- If TH is on, just parse the quote only
  			th_exts <- extension thEnabled	
  			let (AI end _) = i1
- 			if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
+ 			if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
  				   else lit_error i2
  
- finish_char_tok :: SrcLoc -> Char -> P (Located Token)
+ finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
  finish_char_tok loc ch	-- We've already seen the closing quote
  			-- Just need to check for trailing #
    = do	magicHash <- extension magicHashEnabled
@@@ -1319,11 -1309,11 +1326,11 @@@
  		case alexGetChar' i of
  			Just ('#',i@(AI end _)) -> do
  				setInput i
- 				return (L (mkSrcSpan loc end) (ITprimchar ch))
+ 				return (L (mkRealSrcSpan loc end) (ITprimchar ch))
  			_other ->
- 				return (L (mkSrcSpan loc end) (ITchar ch))
+ 				return (L (mkRealSrcSpan loc end) (ITchar ch))
  	    else do
- 		   return (L (mkSrcSpan loc end) (ITchar ch))
+ 		   return (L (mkRealSrcSpan loc end) (ITchar ch))
  
  isAny :: Char -> Bool
  isAny c | c > '\x7f' = isPrint c
@@@ -1458,10 -1448,10 +1465,10 @@@ lex_quasiquote_tok span buf len = d
    quoteStart <- getSrcLoc              
    quote <- lex_quasiquote ""
    end <- getSrcLoc 
-   return (L (mkSrcSpan (srcSpanStart span) end)
+   return (L (mkRealSrcSpan (realSrcSpanStart span) end)
             (ITquasiQuote (mkFastString quoter,
                            mkFastString (reverse quote),
-                           mkSrcSpan quoteStart end)))
+                           mkRealSrcSpan quoteStart end)))
  
  lex_quasiquote :: String -> P String
  lex_quasiquote s = do
@@@ -1489,12 -1479,12 +1496,12 @@@
  
  warn :: DynFlag -> SDoc -> Action
  warn option warning srcspan _buf _len = do
-     addWarning option srcspan warning
+     addWarning option (RealSrcSpan srcspan) warning
      lexToken
  
  warnThen :: DynFlag -> SDoc -> Action -> Action
  warnThen option warning action srcspan buf len = do
-     addWarning option srcspan warning
+     addWarning option (RealSrcSpan srcspan) warning
      action srcspan buf len
  
  -- -----------------------------------------------------------------------------
@@@ -1517,22 -1507,22 +1524,22 @@@ data PState = PState 
  	buffer	   :: StringBuffer,
          dflags     :: DynFlags,
          messages   :: Messages,
-         last_loc   :: SrcSpan,	-- pos of previous token
+         last_loc   :: RealSrcSpan,	-- pos of previous token
  	last_len   :: !Int,	-- len of previous token
-         loc        :: SrcLoc,   -- current loc (end of prev token + 1)
+         loc        :: RealSrcLoc,   -- current loc (end of prev token + 1)
  	extsBitmap :: !Int,	-- bitmap that determines permitted extensions
  	context	   :: [LayoutContext],
  	lex_state  :: [Int],
          -- Used in the alternative layout rule:
          -- These tokens are the next ones to be sent out. They are
          -- just blindly emitted, without the rule looking at them again:
-         alr_pending_implicit_tokens :: [Located Token],
+         alr_pending_implicit_tokens :: [RealLocated Token],
          -- This is the next token to be considered or, if it is Nothing,
          -- we need to get the next token from the input stream:
-         alr_next_token :: Maybe (Located Token),
+         alr_next_token :: Maybe (RealLocated Token),
          -- This is what we consider to be the locatino of the last token
          -- emitted:
-         alr_last_loc :: SrcSpan,
+         alr_last_loc :: RealSrcSpan,
          -- The stack of layout contexts:
          alr_context :: [ALRContext],
          -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
@@@ -1540,8 -1530,7 +1547,8 @@@
          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
@@@ -1574,13 -1563,13 +1581,13 @@@ thenP :: P a -> (a -> P b) -> P 
  		PFailed span err -> PFailed span err
  
  failP :: String -> P a
- failP msg = P $ \s -> PFailed (last_loc s) (text msg)
+ failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
  
  failMsgP :: String -> P a
- failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
+ failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
  
- failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
- failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
+ failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
+ failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
  
  failSpanMsgP :: SrcSpan -> SDoc -> P a
  failSpanMsgP span msg = P $ \_ -> PFailed span msg
@@@ -1605,26 -1594,19 +1612,26 @@@ getExts = P $ \s -> POk s (extsBitmap s
  setExts :: (Int -> Int) -> P ()
  setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
  
- setSrcLoc :: SrcLoc -> P ()
+ setSrcLoc :: RealSrcLoc -> 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 RealSrcLoc
  getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc
  
- setLastToken :: SrcSpan -> Int -> P ()
+ setLastToken :: RealSrcSpan -> Int -> P ()
  setLastToken loc len = P $ \s -> POk s { 
    last_loc=loc, 
    last_len=len
    } ()
  
- data AlexInput = AI SrcLoc StringBuffer
+ data AlexInput = AI RealSrcLoc StringBuffer
  
  alexInputPrevChar :: AlexInput -> Char
  alexInputPrevChar (AI _ buf) = prevChar buf '\n'
@@@ -1710,7 -1692,7 +1717,7 @@@ popLexState = P $ \s@PState{ lex_state=
  getLexState :: P Int
  getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls
  
- popNextToken :: P (Maybe (Located Token))
+ popNextToken :: P (Maybe (RealLocated Token))
  popNextToken
      = P $ \s@PState{ alr_next_token = m } ->
                POk (s {alr_next_token = Nothing}) m
@@@ -1724,10 -1706,10 +1731,10 @@@ activeContext = d
      ([],Nothing) -> return impt
      _other       -> return True
  
- setAlrLastLoc :: SrcSpan -> P ()
+ setAlrLastLoc :: RealSrcSpan -> P ()
  setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) ()
  
- getAlrLastLoc :: P SrcSpan
+ getAlrLastLoc :: P RealSrcSpan
  getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l
  
  getALRContext :: P [ALRContext]
@@@ -1744,7 -1726,7 +1751,7 @@@ setJustClosedExplicitLetBlock :: Bool -
  setJustClosedExplicitLetBlock b
   = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) ()
  
- setNextToken :: Located Token -> P ()
+ setNextToken :: RealLocated Token -> P ()
  setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) ()
  
  implicitTokenPending :: P Bool
@@@ -1754,14 -1736,14 +1761,14 @@@ implicitTokenPendin
                [] -> POk s False
                _  -> POk s True
  
- popPendingImplicitToken :: P (Maybe (Located Token))
+ popPendingImplicitToken :: P (Maybe (RealLocated Token))
  popPendingImplicitToken
      = P $ \s@PState{ alr_pending_implicit_tokens = ts } ->
                case ts of
                [] -> POk s Nothing
                (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t)
  
- setPendingImplicitTokens :: [Located Token] -> P ()
+ setPendingImplicitTokens :: [RealLocated Token] -> P ()
  setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) ()
  
  getAlrExpectingOCurly :: P (Maybe ALRLayout)
@@@ -1825,8 -1807,6 +1832,8 @@@ relaxedLayoutBit :: In
  relaxedLayoutBit = 24
  nondecreasingIndentationBit :: Int
  nondecreasingIndentationBit = 25
 +hetMetBit :: Int
 +hetMetBit = 31
  
  always :: Int -> Bool
  always           _     = True
@@@ -1834,8 -1814,6 +1841,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
@@@ -1873,20 -1851,20 +1880,20 @@@ nondecreasingIndentation flags = testBi
  
  -- PState for parsing options pragmas
  --
- pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+ pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
  pragState dynflags buf loc = (mkPState dynflags buf loc) {
                                   lex_state = [bol, option_prags, 0]
                               }
  
  -- create a parse state
  --
- mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState
+ mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState
  mkPState flags buf loc =
    PState {
        buffer        = buf,
        dflags        = flags,
        messages      = emptyMessages,
-       last_loc      = mkSrcSpan loc loc,
+       last_loc      = mkRealSrcSpan loc loc,
        last_len      = 0,
        loc           = loc,
        extsBitmap    = fromIntegral bitmap,
@@@ -1894,17 -1872,15 +1901,17 @@@
        lex_state     = [bol, 0],
        alr_pending_implicit_tokens = [],
        alr_next_token = Nothing,
-       alr_last_loc = noSrcSpan,
+       alr_last_loc = alrInitialLoc (fsLit "<no file>"),
        alr_context = [],
        alr_expecting_ocurly = Nothing,
 -      alr_justClosedExplicitLetBlock = False
 +      alr_justClosedExplicitLetBlock = False,
 +      code_type_bracket_depth = 0
      }
      where
        bitmap =     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
@@@ -1952,7 -1928,7 +1959,7 @@@ popContext = P $ \ s@(PState{ buffer = 
                                last_len = len, last_loc = last_loc }) ->
    case ctx of
  	(_:tl) -> POk s{ context = tl } ()
- 	[]     -> PFailed last_loc (srcParseErr buf len)
+ 	[]     -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
  
  -- Push a new layout context at the indentation of the last token read.
  -- This is only used at the outer level of a module when the 'module'
@@@ -1991,7 -1967,7 +1998,7 @@@ srcParseErr buf le
  srcParseFail :: P a
  srcParseFail = P $ \PState{ buffer = buf, last_len = len, 	
  			    last_loc = last_loc } ->
-     PFailed last_loc (srcParseErr buf len)
+     PFailed (RealSrcSpan last_loc) (srcParseErr buf len)
  
  -- A lexical error is reported at a particular position in the source file,
  -- not over a token range.
@@@ -2009,11 -1985,11 +2016,11 @@@ lexer :: (Located Token -> P a) -> P 
  lexer cont = do
    alr <- extension alternativeLayoutRule
    let lexTokenFun = if alr then lexTokenAlr else lexToken
-   tok@(L _span _tok__) <- lexTokenFun
-   --trace ("token: " ++ show _tok__) $ do
-   cont tok
+   (L span tok) <- lexTokenFun
+   --trace ("token: " ++ show tok) $ do
+   cont (L (RealSrcSpan span) tok)
  
- lexTokenAlr :: P (Located Token)
+ lexTokenAlr :: P (RealLocated Token)
  lexTokenAlr = do mPending <- popPendingImplicitToken
                   t <- case mPending of
                        Nothing ->
@@@ -2035,7 -2011,7 +2042,7 @@@
                       _       -> return ()
                   return t
  
- alternativeLayoutRuleToken :: Located Token -> P (Located Token)
+ alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token)
  alternativeLayoutRuleToken t
      = do context <- getALRContext
           lastLoc <- getAlrLastLoc
@@@ -2046,8 -2022,7 +2053,7 @@@
           let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags
               thisLoc = getLoc t
               thisCol = srcSpanStartCol thisLoc
-              newLine = (lastLoc == noSrcSpan)
-                     || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc)
+              newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc
           case (unLoc t, context, mExpectingOCurly) of
               -- This case handles a GHC extension to the original H98
               -- layout rule...
@@@ -2107,7 -2082,7 +2113,7 @@@
               (ITwhere, ALRLayout _ col : ls, _)
                | newLine && thisCol == col && transitional ->
                   do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                                thisLoc
+                                (RealSrcSpan thisLoc)
                                 (transitionalAlternativeLayoutWarning
                                      "`where' clause at the same depth as implicit layout block")
                      setALRContext ls
@@@ -2119,7 -2094,7 +2125,7 @@@
               (ITvbar, ALRLayout _ col : ls, _)
                | newLine && thisCol == col && transitional ->
                   do addWarning Opt_WarnAlternativeLayoutRuleTransitional
-                                thisLoc
+                                (RealSrcSpan thisLoc)
                                 (transitionalAlternativeLayoutWarning
                                      "`|' at the same depth as implicit layout block")
                      setALRContext ls
@@@ -2234,14 -2209,14 +2240,14 @@@ topNoLayoutContainsCommas [] = Fals
  topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls
  topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b
  
- lexToken :: P (Located Token)
+ lexToken :: P (RealLocated Token)
  lexToken = do
    inp@(AI loc1 buf) <- getInput
    sc <- getLexState
    exts <- getExts
    case alexScanUser exts inp sc of
      AlexEOF -> do
-         let span = mkSrcSpan loc1 loc1
+         let span = mkRealSrcSpan loc1 loc1
          setLastToken span 0
          return (L span ITeof)
      AlexError (AI loc2 buf) ->
@@@ -2251,12 -2226,12 +2257,12 @@@
          lexToken
      AlexToken inp2@(AI end buf2) _ t -> do
          setInput inp2
-         let span = mkSrcSpan loc1 end
+         let span = mkRealSrcSpan loc1 end
          let bytes = byteDiff buf buf2
          span `seq` setLastToken span bytes
          t span buf bytes
  
- reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a
+ reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a
  reportLexError loc1 loc2 buf str
    | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")
    | otherwise =
@@@ -2267,7 -2242,7 +2273,7 @@@
      then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")
      else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)
  
- lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token]
+ lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]
  lexTokenStream buf loc dflags = unP go initState
      where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream
            initState = mkPState dflags' buf loc
@@@ -2307,7 -2282,8 +2313,8 @@@ oneWordPrags = Map.fromList([("rules", 
                             ("core", token ITcore_prag),
                             ("unpack", token ITunpack_prag),
                             ("ann", token ITann_prag),
-                            ("vectorize", token ITvect_prag)])
+                            ("vectorize", token ITvect_prag),
+                            ("novectorize", token ITnovect_prag)])
  
  twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)),
                               ("notinline conlike", token (ITinline_prag NoInline ConLike)),
@@@ -2333,6 -2309,7 +2340,7 @@@ clean_pragma prag = canon_ws (map toLow
                                                "noinline" -> "notinline"
                                                "specialise" -> "specialize"
                                                "vectorise" -> "vectorize"
+                                               "novectorise" -> "novectorize"
                                                "constructorlike" -> "conlike"
                                                _ -> prag'
                            canon_ws s = unwords (map canonical (words s))
diff --combined compiler/parser/Parser.y.pp
index a71323f,b663ac2..1a847ec
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@@ -39,11 -39,9 +39,9 @@@ 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, 
- 			  mkSrcLoc, mkSrcSpan )
+ import SrcLoc
  import Module
  import StaticFlags	( opt_SccProfilingOn, opt_Hpc )
  import Type		( Kind, liftedTypeKind, unliftedTypeKind )
@@@ -254,21 -252,22 +252,22 @@@ incorrect
   'by'       { L _ ITby }        -- for list transform extension
   'using'    { L _ ITusing }     -- for list transform extension
  
-  '{-# INLINE'      	  { L _ (ITinline_prag _ _) }
-  '{-# SPECIALISE'  	  { L _ ITspec_prag }
+  '{-# INLINE'             { L _ (ITinline_prag _ _) }
+  '{-# SPECIALISE'         { L _ ITspec_prag }
   '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
-  '{-# SOURCE'	   { L _ ITsource_prag }
-  '{-# RULES'	   { L _ ITrules_prag }
-  '{-# CORE'        { L _ ITcore_prag }              -- hdaume: annotated core
-  '{-# SCC'	   { L _ ITscc_prag }
-  '{-# GENERATED'   { L _ ITgenerated_prag }
-  '{-# DEPRECATED'  { L _ ITdeprecated_prag }
-  '{-# WARNING'     { L _ ITwarning_prag }
-  '{-# UNPACK'      { L _ ITunpack_prag }
-  '{-# ANN'         { L _ ITann_prag }
+  '{-# SOURCE'      				{ L _ ITsource_prag }
+  '{-# RULES'       				{ L _ ITrules_prag }
+  '{-# CORE'        				{ L _ ITcore_prag }              -- hdaume: annotated core
+  '{-# SCC'                { L _ ITscc_prag }
+  '{-# GENERATED'          { L _ ITgenerated_prag }
+  '{-# DEPRECATED'         { L _ ITdeprecated_prag }
+  '{-# 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 }
+  '{-# NOVECTORISE'        { L _ ITnovect_prag }
+  '#-}'             				{ L _ ITclose_prag }
  
   '..'		{ L _ ITdotdot }  			-- reserved symbols
   ':'		{ L _ ITcolon }
@@@ -306,11 -305,6 +305,11 @@@
   '#)'		{ L _ ITcubxparen }
   '(|'		{ L _ IToparenbar }
   '|)'		{ L _ ITcparenbar }
 + '<['		{ L _ ITopenBrak }
 + ']>'		{ L _ ITcloseBrak }
 + '~~'		{ L _ ITescape }
 + '~~$'		{ L _ ITescapeDollar }
 + '%%'		{ L _ ITdoublePercent }
   ';'		{ L _ ITsemi }
   ','		{ L _ ITcomma }
   '`'		{ L _ ITbackquote }
@@@ -476,7 -470,7 +475,7 @@@ export 	:: { LIE RdrName 
  	|  oqtycon '(' ')'		{ LL (IEThingWith (unLoc $1) []) }
  	|  oqtycon '(' qcnames ')'	{ LL (IEThingWith (unLoc $1) (reverse $3)) }
  	|  'module' modid		{ LL (IEModuleContents (unLoc $2)) }
 -
 +        | '<[' incdepth export decdepth ']>' { $3 }
  qcnames :: { [RdrName] }
  	:  qcnames ',' qcname_ext	{ unLoc $3 : $1 }
  	|  qcname_ext			{ [unLoc $1]  }
@@@ -553,33 -547,34 +552,34 @@@ ops   	:: { Located [Located RdrName] 
  -- Top-Level Declarations
  
  topdecls :: { OrdList (LHsDecl RdrName) }
-         : topdecls ';' topdecl		        { $1 `appOL` $3 }
-         | topdecls ';'			        { $1 }
- 	| topdecl			        { $1 }
+         : topdecls ';' topdecl                  { $1 `appOL` $3 }
+         | topdecls ';'                          { $1 }
+         | topdecl                               { $1 }
  
  topdecl :: { OrdList (LHsDecl RdrName) }
-   	: cl_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
-   	| ty_decl			{ unitOL (L1 (TyClD (unLoc $1))) }
- 	| 'instance' inst_type where_inst
- 	    { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
- 	      in 
- 	      unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
+         : cl_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+         | ty_decl                       { unitOL (L1 (TyClD (unLoc $1))) }
+         | 'instance' inst_type where_inst
+             { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
+               in 
+               unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))}
          | stand_alone_deriving                  { unitOL (LL (DerivD (unLoc $1))) }
- 	| 'default' '(' comma_types0 ')'	{ unitOL (LL $ DefD (DefaultDecl $3)) }
- 	| 'foreign' fdecl			{ unitOL (LL (unLoc $2)) }
+         | 'default' '(' comma_types0 ')'        { unitOL (LL $ DefD (DefaultDecl $3)) }
+         | 'foreign' fdecl                       { unitOL (LL (unLoc $2)) }
          | '{-# 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 }
- 
- 	-- Template Haskell Extension
- 	-- The $(..) form is one possible form of infixexp
- 	-- but we treat an arbitrary expression just as if 
- 	-- it had a $(..) wrapped around it
- 	| infixexp 				{ unitOL (LL $ mkTopSpliceDecl $1) } 
+         | '{-# RULES' rules '#-}'               { $2 }
+         | '{-# VECTORISE_SCALAR' qvar '#-}'     { unitOL $ LL $ VectD (HsVect   $2 Nothing) }
+         | '{-# VECTORISE' qvar '=' exp '#-}'    { unitOL $ LL $ VectD (HsVect   $2 (Just $4)) }
+         | '{-# NOVECTORISE' qvar '#-}'     			{ unitOL $ LL $ VectD (HsNoVect $2) }
+         | annotation { unitOL $1 }
+         | decl                                  { unLoc $1 }
+ 
+         -- Template Haskell Extension
+         -- The $(..) form is one possible form of infixexp
+         -- but we treat an arbitrary expression just as if 
+         -- it had a $(..) wrapped around it
+         | infixexp                              { unitOL (LL $ mkTopSpliceDecl $1) } 
  
  -- Type classes
  --
@@@ -1025,7 -1020,6 +1025,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) }
@@@ -1227,7 -1221,6 +1227,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) }
@@@ -1269,12 -1262,8 +1269,12 @@@ quasiquote :: { Located (HsQuasiQuote R
  	: TH_QUASIQUOTE   { let { loc = getLoc $1
                                  ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
                                  ; quoterId = mkUnqual varName quoter }
-                             in L1 (mkHsQuasiQuote quoterId quoteSpan quote) }
+                             in L1 (mkHsQuasiQuote quoterId (RealSrcSpan 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 }
@@@ -1282,7 -1271,6 +1282,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 }
@@@ -1408,11 -1396,6 +1408,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 -}			{ [] }
@@@ -1846,7 -1829,7 +1846,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") }
@@@ -1871,10 -1854,9 +1871,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 f84f0a4,d226cbe..a2c81de
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@@ -213,34 -213,6 +213,34 @@@ basicKnownKeyName
  	-- Other classes
  	randomClassName, randomGenClassName, monadPlusClassName,
  
 +        -- Code types
 +        hetmet_brak_name, hetmet_esc_name, hetmet_csp_name, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_name,
 +        hetmet_guest_integer_literal_name, hetmet_guest_string_literal_name,
 +                                         hetmet_guest_char_literal_name,
 +        hetmet_PGArrow_name,
 +        hetmet_PGArrow_unit_name,
 +        hetmet_PGArrow_tensor_name,
 +        hetmet_PGArrow_exponent_name,
 +        hetmet_pga_id_name,
 +        hetmet_pga_comp_name,
 +        hetmet_pga_first_name,
 +        hetmet_pga_second_name,
 +        hetmet_pga_cancell_name,
 +        hetmet_pga_cancelr_name,
 +        hetmet_pga_uncancell_name,
 +        hetmet_pga_uncancelr_name,
 +        hetmet_pga_assoc_name,
 +        hetmet_pga_unassoc_name,
 +        hetmet_pga_copy_name,
 +        hetmet_pga_drop_name,
 +        hetmet_pga_swap_name,
 +        hetmet_pga_applyl_name,
 +        hetmet_pga_applyr_name,
 +        hetmet_pga_curryl_name,
 +        hetmet_pga_curryr_name,
 +        hetmet_pga_loopl_name,
 +        hetmet_pga_loopr_name,
 +
          -- Annotation type checking
          toAnnotationWrapperName
  
@@@ -304,12 -276,9 +304,12 @@@ gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDE
      gHC_MAGIC,
      gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING,
      gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST,
 +    gHC_HETMET_CODETYPES,
 +    gHC_HETMET_PRIVATE,
 +    gHC_HETMET_GARROW,
      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,
+     gHC_CONC, gHC_IO, gHC_IO_Exception,
+     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
      gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS,
      dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP,
      aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,
@@@ -331,9 -300,6 +331,9 @@@ 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_HETMET_CODETYPES = mkBaseModule (fsLit "GHC.HetMet.CodeTypes")
 +gHC_HETMET_PRIVATE   = mkBaseModule (fsLit "GHC.HetMet.Private")
 +gHC_HETMET_GARROW    = mkBaseModule (fsLit "GHC.HetMet.GArrow")
  gHC_LIST        = mkBaseModule (fsLit "GHC.List")
  gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")
  dATA_TUPLE      = mkBaseModule (fsLit "Data.Tuple")
@@@ -341,14 -307,12 +341,12 @@@ dATA_EITHER	= mkBaseModule (fsLit "Data
  dATA_STRING	= mkBaseModule (fsLit "Data.String")
  dATA_FOLDABLE	= mkBaseModule (fsLit "Data.Foldable")
  dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
- gHC_PACK	= mkBaseModule (fsLit "GHC.Pack")
  gHC_CONC	= mkBaseModule (fsLit "GHC.Conc")
  gHC_IO    	= mkBaseModule (fsLit "GHC.IO")
  gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
  gHC_ST		= mkBaseModule (fsLit "GHC.ST")
  gHC_ARR		= mkBaseModule (fsLit "GHC.Arr")
  gHC_STABLE	= mkBaseModule (fsLit "GHC.Stable")
- gHC_ADDR	= mkBaseModule (fsLit "GHC.Addr")
  gHC_PTR		= mkBaseModule (fsLit "GHC.Ptr")
  gHC_ERR		= mkBaseModule (fsLit "GHC.Err")
  gHC_REAL	= mkBaseModule (fsLit "GHC.Real")
@@@ -918,66 -882,6 +916,66 @@@ toPName             pkg = varQual (gHC_
  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, hetmet_flatten_name, hetmet_unflatten_name, hetmet_flattened_id_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_flatten_name  = varQual gHC_HETMET_CODETYPES (fsLit "pga_flatten") hetmet_flatten_key
 +hetmet_unflatten_name  = varQual gHC_HETMET_CODETYPES (fsLit "pga_unflatten") hetmet_unflatten_key
 +hetmet_flattened_id_name  = varQual gHC_HETMET_CODETYPES (fsLit "pga_flattened_id") hetmet_flattened_id_key
 +hetmet_guest_integer_literal_name = varQual gHC_HETMET_CODETYPES (fsLit "guestIntegerLiteral") hetmet_guest_integer_literal_key
 +hetmet_guest_string_literal_name  = varQual gHC_HETMET_CODETYPES (fsLit "guestStringLiteral")  hetmet_guest_string_literal_key
 +hetmet_guest_char_literal_name    = varQual gHC_HETMET_CODETYPES (fsLit "guestCharLiteral")    hetmet_guest_char_literal_key
 +
 +hetmet_PGArrow_name :: Name
 +hetmet_PGArrow_name = tcQual gHC_HETMET_PRIVATE (fsLit "PGArrow") hetmet_PGArrow_key
 +hetmet_PGArrow_unit_name :: Name
 +hetmet_PGArrow_unit_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowUnit") hetmet_PGArrow_unit_key
 +hetmet_PGArrow_tensor_name :: Name
 +hetmet_PGArrow_tensor_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowTensor") hetmet_PGArrow_tensor_key
 +hetmet_PGArrow_exponent_name :: Name
 +hetmet_PGArrow_exponent_name = tcQual gHC_HETMET_GARROW (fsLit "GArrowExponent") hetmet_PGArrow_exponent_key
 +hetmet_pga_id_name :: Name
 +hetmet_pga_id_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_id") hetmet_pga_id_key
 +hetmet_pga_comp_name :: Name
 +hetmet_pga_comp_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_comp") hetmet_pga_comp_key
 +hetmet_pga_first_name :: Name
 +hetmet_pga_first_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_first") hetmet_pga_first_key
 +hetmet_pga_second_name :: Name
 +hetmet_pga_second_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_second") hetmet_pga_second_key
 +hetmet_pga_cancell_name :: Name
 +hetmet_pga_cancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancell") hetmet_pga_cancell_key
 +hetmet_pga_cancelr_name :: Name
 +hetmet_pga_cancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_cancelr") hetmet_pga_cancelr_key
 +hetmet_pga_uncancell_name :: Name
 +hetmet_pga_uncancell_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancell") hetmet_pga_uncancell_key
 +hetmet_pga_uncancelr_name :: Name
 +hetmet_pga_uncancelr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_uncancelr") hetmet_pga_uncancelr_key
 +hetmet_pga_assoc_name :: Name
 +hetmet_pga_assoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_assoc") hetmet_pga_assoc_key
 +hetmet_pga_unassoc_name :: Name
 +hetmet_pga_unassoc_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_unassoc") hetmet_pga_unassoc_key
 +hetmet_pga_copy_name :: Name
 +hetmet_pga_copy_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_copy") hetmet_pga_copy_key
 +hetmet_pga_drop_name :: Name
 +hetmet_pga_drop_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_drop") hetmet_pga_drop_key
 +hetmet_pga_swap_name :: Name
 +hetmet_pga_swap_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_swap") hetmet_pga_swap_key
 +hetmet_pga_applyl_name :: Name
 +hetmet_pga_applyl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyl") hetmet_pga_applyl_key
 +hetmet_pga_applyr_name :: Name
 +hetmet_pga_applyr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_applyr") hetmet_pga_applyr_key
 +hetmet_pga_curryl_name :: Name
 +hetmet_pga_curryl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryl") hetmet_pga_curryl_key
 +hetmet_pga_curryr_name :: Name
 +hetmet_pga_curryr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_curryr") hetmet_pga_curryr_key
 +hetmet_pga_loopl_name :: Name
 +hetmet_pga_loopl_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopl") hetmet_pga_loopl_key
 +hetmet_pga_loopr_name :: Name
 +hetmet_pga_loopr_name = varQual gHC_HETMET_PRIVATE (fsLit "pga_loopr") hetmet_pga_loopr_key
 +
  -- IO things
  ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName,
      failIOName :: Name
@@@ -1382,10 -1286,6 +1380,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}
  
  %************************************************************************
@@@ -1590,70 -1490,6 +1588,70 @@@ liftMIdKey      = mkPreludeMiscIdUniqu
  groupMIdKey     = mkPreludeMiscIdUnique 133
  mzipIdKey       = mkPreludeMiscIdUnique 134
  
 +-- code types
 +hetMetCodeTypeTyConKey :: Unique
 +hetMetCodeTypeTyConKey			= mkPreludeTyConUnique 135
 +
 +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
 +hetmet_PGArrow_key :: Unique
 +hetmet_PGArrow_key = mkPreludeMiscIdUnique 137
 +hetmet_pga_id_key :: Unique
 +hetmet_pga_id_key = mkPreludeMiscIdUnique 138
 +hetmet_pga_comp_key :: Unique
 +hetmet_pga_comp_key = mkPreludeMiscIdUnique 139
 +hetmet_pga_first_key :: Unique
 +hetmet_pga_first_key = mkPreludeMiscIdUnique 140
 +hetmet_pga_second_key :: Unique
 +hetmet_pga_second_key = mkPreludeMiscIdUnique 141
 +hetmet_pga_cancell_key :: Unique
 +hetmet_pga_cancell_key = mkPreludeMiscIdUnique 142
 +hetmet_pga_cancelr_key :: Unique
 +hetmet_pga_cancelr_key = mkPreludeMiscIdUnique 143
 +hetmet_pga_uncancell_key :: Unique
 +hetmet_pga_uncancell_key = mkPreludeMiscIdUnique 144
 +hetmet_pga_uncancelr_key :: Unique
 +hetmet_pga_uncancelr_key = mkPreludeMiscIdUnique 145
 +hetmet_pga_assoc_key :: Unique
 +hetmet_pga_assoc_key = mkPreludeMiscIdUnique 146
 +hetmet_pga_unassoc_key :: Unique
 +hetmet_pga_unassoc_key = mkPreludeMiscIdUnique 147
 +hetmet_pga_copy_key :: Unique
 +hetmet_pga_copy_key = mkPreludeMiscIdUnique 148
 +hetmet_pga_drop_key :: Unique
 +hetmet_pga_drop_key = mkPreludeMiscIdUnique 149
 +hetmet_pga_swap_key :: Unique
 +hetmet_pga_swap_key = mkPreludeMiscIdUnique 150
 +hetmet_pga_applyl_key :: Unique
 +hetmet_pga_applyl_key = mkPreludeMiscIdUnique 151
 +hetmet_pga_applyr_key :: Unique
 +hetmet_pga_applyr_key = mkPreludeMiscIdUnique 152
 +hetmet_pga_curryl_key :: Unique
 +hetmet_pga_curryl_key = mkPreludeMiscIdUnique 153
 +hetmet_pga_curryr_key :: Unique
 +hetmet_pga_curryr_key = mkPreludeMiscIdUnique 154
 +hetmet_flatten_key = mkPreludeMiscIdUnique 155
 +hetmet_unflatten_key = mkPreludeMiscIdUnique 156
 +hetmet_flattened_id_key = mkPreludeMiscIdUnique 157
 +hetmet_PGArrow_unit_key :: Unique
 +hetmet_PGArrow_unit_key = mkPreludeMiscIdUnique 158
 +hetmet_PGArrow_tensor_key :: Unique
 +hetmet_PGArrow_tensor_key = mkPreludeMiscIdUnique 159
 +hetmet_PGArrow_exponent_key :: Unique
 +hetmet_PGArrow_exponent_key = mkPreludeMiscIdUnique 160
 +
 +hetmet_brak_key, hetmet_esc_key, hetmet_csp_key, hetmet_flatten_key, hetmet_unflatten_key, hetmet_flattened_id_key :: Unique
 +hetmet_brak_key    = mkPreludeMiscIdUnique 161
 +hetmet_esc_key     = mkPreludeMiscIdUnique 162
 +hetmet_csp_key     = mkPreludeMiscIdUnique 163
 +
 +hetmet_pga_loopl_key :: Unique
 +hetmet_pga_loopl_key = mkPreludeMiscIdUnique 164
 +hetmet_pga_loopr_key :: Unique
 +hetmet_pga_loopr_key = mkPreludeMiscIdUnique 165
 +
  
  ---------------- Template Haskell -------------------
  --	USES IdUniques 200-499
@@@ -1669,7 -1505,7 +1667,7 @@@
  
  \begin{code}
  numericTyKeys :: [Unique]
 -numericTyKeys = 
 +numericTyKeys =
  	[ wordTyConKey
  	, intTyConKey
  	, integerTyConKey
diff --combined compiler/rename/RnEnv.lhs
index a6503a8,4492b52..1301e61
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@@ -36,7 -36,6 +36,7 @@@ module RnEnv 
  
  import LoadIface	( loadInterfaceForName, loadSrcInterface )
  import IfaceEnv		( lookupOrig, newGlobalBinder, newIPName )
 +import TcEnv		( getHetMetLevel )
  import HsSyn
  import RdrHsSyn		( extractHsTyRdrTyVars )
  import RdrName
@@@ -289,7 -288,7 +289,7 @@@ lookupSubBndr parent doc rdr_nam
  		-- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
  		--     The latter does pickGREs, but we want to allow 'x'
  		--     even if only 'M.x' is in scope
- 	    [gre] -> do { addUsedRdrNames (used_rdr_names gre)
+ 	    [gre] -> do { addUsedRdrName gre (used_rdr_name gre)
                          ; return (gre_name gre) }
  	    []    -> do { addErr (unknownSubordinateErr doc rdr_name)
  			; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
@@@ -297,6 -296,8 +297,8 @@@
  	    gres  -> do { addNameClashErrRn rdr_name gres
  			; return (gre_name (head gres)) } }
    where
+     rdr_occ = rdrNameOcc rdr_name    
+ 
      pick NoParent gres		-- Normal lookup 
        = pickGREs rdr_name gres
      pick (ParentIs p) gres	-- Disambiguating lookup
@@@ -307,13 -308,20 +309,20 @@@
      right_parent _ _                               = False
  
      -- Note [Usage for sub-bndrs]
-     used_rdr_names gre
-       | isQual rdr_name = [rdr_name]
+     used_rdr_name gre
+       | isQual rdr_name = rdr_name
        | otherwise       = case gre_prov gre of
-                             LocalDef -> [rdr_name]
- 			    Imported is -> map mk_qual_rdr is
-     mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ
-     rdr_occ = rdrNameOcc rdr_name    
+                             LocalDef    -> rdr_name
+ 			    Imported is -> used_rdr_name_from_is is
+ 
+     used_rdr_name_from_is imp_specs	-- rdr_name is unqualified
+       | not (all (is_qual . is_decl) imp_specs) 
+       = rdr_name    -- An unqualified import is available
+       | otherwise
+       = 	    -- Only qualified imports available, so make up 
+ 		    -- a suitable qualifed name from the first imp_spec
+         ASSERT( not (null imp_specs) )
+         mkRdrQual (is_as (is_decl (head imp_specs))) rdr_occ
  
  newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
  newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
@@@ -335,13 -343,21 +344,21 @@@ Note [Usage for sub-bndrs
  ~~~~~~~~~~~~~~~~~~~~~~~~~~
  If you have this
     import qualified M( C( f ) ) 
-    intance M.C T where
+    instance M.C T where
       f x = x
  then is the qualified import M.f used?  Obviously yes.
  But the RdrName used in the instance decl is unqualified.  In effect,
  we fill in the qualification by looking for f's whose class is M.C
  But when adding to the UsedRdrNames we must make that qualification
- explicit, otherwise we get "Redundant import of M.C".
+ explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".
+ 
+ So we make up a suitable (fake) RdrName.  But be careful
+    import qualifed M
+    import M( C(f) )
+    instance C T where
+      f x = x
+ Here we want to record a use of 'f', not of 'M.f', otherwise
+ we'll miss the fact that the qualified import is redundant.
  
  --------------------------------------------------
  --		Occurrences
@@@ -769,14 -785,14 +786,14 @@@ lookupIfThenEls
  lookupSyntaxName :: Name 				-- The standard name
  	         -> RnM (SyntaxExpr Name, FreeVars)	-- Possibly a non-standard name
  lookupSyntaxName std_name
 -  = xoptM Opt_RebindableSyntax		`thenM` \ rebindable_on -> 
 -    if not rebindable_on then normal_case 
 -    else
 -	-- Get the similarly named thing from the local environment
 -    lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name ->
 -    return (HsVar usr_name, unitFV usr_name)
 -  where
 -    normal_case = return (HsVar std_name, emptyFVs)
 +  = do ec <- getHetMetLevel
 +       std_name' <- return $ setNameDepth (length ec) std_name
 +       rebindable_on <- xoptM Opt_RebindableSyntax
 +       if not rebindable_on
 +         then return (HsVar std_name', emptyFVs)
 +         else do usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name'))
 +                 return (HsVar usr_name, unitFV usr_name)
 +               -- Get the similarly named thing from the local environment
  
  lookupSyntaxTable :: [Name]				-- Standard names
  		  -> RnM (SyntaxTable Name, FreeVars)	-- See comments with HsExpr.ReboundNames
@@@ -1054,7 -1070,11 +1071,11 @@@ unknownNameSuggestErr where_look tried_
    where
      pp_item :: (RdrName, HowInScope) -> SDoc
      pp_item (rdr, Left loc) = quotes (ppr rdr) <+>   -- Locally defined
-                               parens (ptext (sLit "line") <+> int (srcSpanStartLine loc))
+                               parens (ptext (sLit "line") <+> int (srcSpanStartLine loc'))
+         where loc' = case loc of
+                      UnhelpfulSpan _ ->
+                          panic "unknownNameSuggestErr UnhelpfulSpan"
+                      RealSrcSpan l -> l
      pp_item (rdr, Right is) = quotes (ppr rdr) <+>   -- Imported
                                parens (ptext (sLit "imported from") <+> ppr (is_mod is))
  
diff --combined compiler/rename/RnHsSyn.lhs
index b958f9d,bfbcdc5..f4fdc3b
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@@ -18,11 -18,11 +18,11 @@@ module RnHsSyn
  
  import HsSyn
  import Class            ( FunDep )
 -import TysWiredIn       ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
 +import TysWiredIn       ( tupleTyCon, listTyCon, parrTyCon, hetMetCodeTypeTyCon, charTyCon )
  import Name             ( Name, getName, isTyVarName )
  import NameSet
  import BasicTypes       ( Boxity )
- import SrcLoc           ( Located(..), unLoc )
+ import SrcLoc
  \end{code}
  
  %************************************************************************
@@@ -38,8 -38,6 +38,8 @@@ charTyCon_name, listTyCon_name, parrTyC
  charTyCon_name    = getName charTyCon
  listTyCon_name    = getName listTyCon
  parrTyCon_name    = getName parrTyCon
 +hetMetCodeTypeTyCon_name :: Name
 +hetMetCodeTypeTyCon_name = getName hetMetCodeTypeTyCon
  
  tupleTyCon_name :: Boxity -> Int -> Name
  tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
@@@ -59,7 -57,6 +59,7 @@@ extractHsTyNames t
      get (HsAppTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
      get (HsListTy ty)          = unitNameSet listTyCon_name `unionNameSets` getl ty
      get (HsPArrTy ty)          = unitNameSet parrTyCon_name `unionNameSets` getl ty
 +    get (HsModalBoxType ecn ty) = (unitNameSet ecn) `unionNameSets` (unitNameSet hetMetCodeTypeTyCon_name) `unionNameSets` (getl ty)
      get (HsTupleTy _ tys)      = extractHsTyNames_s tys
      get (HsFunTy ty1 ty2)      = getl ty1 `unionNameSets` getl ty2
      get (HsPredTy p)           = extractHsPredTyNames p
diff --combined compiler/typecheck/TcHsSyn.lhs
index 4845d70,3b4afae..6ba78d9
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@@ -546,22 -546,6 +546,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 ->
@@@ -1043,6 -1027,10 +1043,10 @@@ zonkVect env (HsVect v (Just e)
         ; e' <- zonkLExpr env e
         ; return $ HsVect v' (Just e')
         }
+ zonkVect env (HsNoVect v)
+   = do { v' <- wrapLocM (zonkIdBndr env) v
+        ; return $ HsNoVect v'
+        }
  \end{code}
  
  %************************************************************************
diff --combined compiler/typecheck/TcHsType.lhs
index f011f19,7d9f93c..f826e72
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@@ -37,7 -37,6 +37,7 @@@ import TcMTyp
  import TcUnify
  import TcIface
  import TcType
 +import TysPrim ( ecKind )
  import {- Kind parts of -} Type
  import Var
  import VarSet
@@@ -300,7 -299,7 +300,7 @@@ kc_check_hs_type (HsParTy ty) exp_kin
    = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') }
  
  kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind
-   = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
+   = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
         ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty
         ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind
         ; return (mkHsAppTys fun_ty' arg_tys') }
@@@ -365,11 -364,6 +365,11 @@@ kc_hs_type (HsPArrTy ty) = d
      ty' <- kcLiftedType ty
      return (HsPArrTy ty', liftedTypeKind)
  
 +kc_hs_type (HsModalBoxType ecn ty) = do
 +    kc_check_hs_type (HsTyVar ecn) (EK ecKind EkUnk)
 +    ty' <- kcLiftedType ty
 +    return (HsModalBoxType ecn ty', liftedTypeKind)
 +
  kc_hs_type (HsKindSig ty k) = do
      ty' <- kc_check_lhs_type ty (EK k EkKindSig)
      return (HsKindSig ty' k, k)
@@@ -393,11 -387,10 +393,10 @@@ kc_hs_type (HsOpTy ty1 op ty2) = d
      return (HsOpTy ty1' op ty2', res_kind)
  
  kc_hs_type (HsAppTy ty1 ty2) = do
+     let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2]
      (fun_ty', fun_kind) <- kc_lhs_type fun_ty
      (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys
      return (mkHsAppTys fun_ty' arg_tys', res_kind)
-   where
-     (fun_ty, arg_tys) = splitHsAppTys ty1 ty2
  
  kc_hs_type (HsPredTy pred)
    = wrongPredErr pred
@@@ -464,20 -457,6 +463,6 @@@ kcCheckApps the_fun fun_kind args ty ex
  	     -- This improves error message; Trac #2994
         ; kc_check_lhs_types args_w_kinds }
  
- splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name])
- splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty]
-   where
-     split (L _ (HsAppTy f a)) as = split f (a:as)
-     split f       	      as = (f,as)
- 
- mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name
- mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty)
- mkHsAppTys fun_ty (arg_ty:arg_tys)
-   = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys
-   where
-     mk_app fun arg = HsAppTy (noLoc fun) arg	-- Add noLocs for inner nodes of
- 					 	-- the application; they are
- 						-- never used 
  
  ---------------------------
  splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
@@@ -591,11 -570,6 +576,11 @@@ ds_type (HsPArrTy ty) = d
      checkWiredInTyCon parrTyCon
      return (mkPArrTy tau_ty)
  
 +ds_type (HsModalBoxType ecn ty) = do
 +    tau_ty <- dsHsType ty
 +    checkWiredInTyCon hetMetCodeTypeTyCon
 +    return (mkHetMetCodeTypeTy (mkTyVar ecn ecKind) tau_ty)
 +
  ds_type (HsTupleTy boxity tys) = do
      tau_tys <- dsHsTypes tys
      checkWiredInTyCon tycon
diff --combined compiler/typecheck/TcRnMonad.lhs
index c86b081,ce84178..43232e5
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@@ -135,8 -135,7 +135,8 @@@ initTc hsc_env hsc_src keep_rn_syntax m
  		tcl_tyvars     = tvs_var,
  		tcl_lie	       = lie_var,
                  tcl_meta       = meta_var,
 -		tcl_untch      = initTyVarUnique
 +		tcl_untch      = initTyVarUnique,
 +                tcl_hetMetLevel    = []
  	     } ;
  	} ;
     
@@@ -495,9 -494,10 +495,10 @@@ getSrcSpanM :: TcRn SrcSpa
  getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
  
  setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
- setSrcSpan loc thing_inside
-   | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
-   | otherwise	      = thing_inside	-- Don't overwrite useful info with useless
+ setSrcSpan loc@(RealSrcSpan _) thing_inside
+     = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+ -- Don't overwrite useful info with useless:
+ setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
  
  addLocM :: (a -> TcM b) -> Located a -> TcM b
  addLocM fn (L loc a) = setSrcSpan loc $ fn a
@@@ -990,10 -990,10 +991,10 @@@ captureConstraints :: TcM a -> TcM (a, 
  -- (captureConstraints m) runs m, and returns the type constraints it generates
  captureConstraints thing_inside
    = do { lie_var <- newTcRef emptyWC ;
- 	 res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
- 			  thing_inside ;
- 	 lie <- readTcRef lie_var ;
- 	 return (res, lie) }
+          res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
+                           thing_inside ;
+          lie <- readTcRef lie_var ;
+          return (res, lie) }
  
  captureUntouchables :: TcM a -> TcM (a, Untouchables)
  captureUntouchables thing_inside
@@@ -1018,14 -1018,21 +1019,21 @@@ setLclTypeEnv lcl_env thing_insid
    = updLclEnv upd thing_inside
    where
      upd env = env { tcl_env = tcl_env lcl_env,
- 		    tcl_tyvars = tcl_tyvars lcl_env }
+                     tcl_tyvars = tcl_tyvars lcl_env }
+ 
+ traceTcConstraints :: String -> TcM ()
+ traceTcConstraints msg
+   = do { lie_var <- getConstraintVar
+        ; lie     <- readTcRef lie_var
+        ; traceTc (msg ++ "LIE:") (ppr lie)
+        }
  \end{code}
  
  
  %************************************************************************
- %*									*
- 	     Template Haskell context
- %*									*
+ %*                                                                      *
+              Template Haskell context
+ %*                                                                      *
  %************************************************************************
  
  \begin{code}
diff --combined ghc.mk
index 3d3c3a6,4508b68..fe5e845
--- a/ghc.mk
+++ b/ghc.mk
@@@ -439,13 -439,13 +439,13 @@@ ghc/stage2/package-data.mk: compiler/st
  # package-data.mk is sufficient, as that in turn depends on all the
  # libraries
  utils/haddock/dist/package-data.mk: compiler/stage2/package-data.mk
- utils/ghc-pwd/dist/package-data.mk: compiler/stage2/package-data.mk
+ utils/ghc-pwd/dist-install/package-data.mk: compiler/stage2/package-data.mk
  utils/ghc-cabal/dist-install/package-data.mk: compiler/stage2/package-data.mk
  
  utils/ghc-pkg/dist-install/package-data.mk: compiler/stage2/package-data.mk
  utils/hsc2hs/dist-install/package-data.mk: compiler/stage2/package-data.mk
- utils/compare_sizes/dist/package-data.mk: compiler/stage2/package-data.mk
- utils/runghc/dist/package-data.mk: compiler/stage2/package-data.mk
+ utils/compare_sizes/dist-install/package-data.mk: compiler/stage2/package-data.mk
+ utils/runghc/dist-install/package-data.mk: compiler/stage2/package-data.mk
  
  # add the final two package.conf dependencies: ghc-prim depends on RTS,
  # and RTS depends on libffi.
@@@ -910,7 -910,7 +910,7 @@@ $(eval $(call bindist,.,
      mk/config.mk.in \
      $(INPLACE_BIN)/mkdirhier \
      utils/ghc-cabal/dist-install/build/tmp/ghc-cabal \
-     utils/ghc-pwd/dist/build/tmp/ghc-pwd \
+     utils/ghc-pwd/dist-install/build/tmp/ghc-pwd \
      $(BINDIST_WRAPPERS) \
      $(BINDIST_PERL_SOURCES) \
      $(BINDIST_LIBS) \
@@@ -1211,15 -1211,3 +1211,15 @@@ phase_0_builds: $(utils/genprimopcode_d
  .PHONY: phase_1_builds
  phase_1_builds: $(PACKAGE_DATA_MKS)
  
 +# -----------------------------------------------------------------------------
 +# Support for writing GHC passes in Coq
 +
 +compiler/hetmet/Makefile:
 +	git submodule update --init compiler/hetmet
 +	cd compiler/hetmet/; git checkout master
 +compiler/hetmet/build/CoqPass.hs: compiler/hetmet/Makefile $(wildcard compiler/hetmet/src/*.v) $(wildcard compiler/hetmet/src/*.hs)
 +	cd compiler/hetmet; make build/CoqPass.hs
 +compiler/stage1/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs
 +	cp compiler/hetmet/build/CoqPass.hs $@
 +compiler/stage2/build/CoqPass.hs: compiler/hetmet/build/CoqPass.hs
 +	cp compiler/hetmet/build/CoqPass.hs $@