[project @ 2000-03-24 17:49:29 by simonpj]

a) Small wibbles to do with inlining and floating

b) Implement Ralf's request, so that one can write

	type F = forall a. a -> a

	f :: Int -> F
	f = ...

   The for-alls inside F are hoisted out to the top of
   the type signature for f.  This applies uniformly to
   all user-written types

diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index bf76243..7df3b66 100644 (file)
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -220,7 +220,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
     let
        n_val_binders = length val_binders
 
     let
        n_val_binders = length val_binders
 

---     max_inline_size = n_val_binders+2
+       max_inline_size = n_val_binders+2

        -- The idea is that if there is an INLINE pragma (inline is True)
        -- and there's a big body, we give a size of n_val_binders+2.  This
        -- This is just enough to fail the no-size-increase test in callSiteInline,
        -- The idea is that if there is an INLINE pragma (inline is True)
        -- and there's a big body, we give a size of n_val_binders+2.  This
        -- This is just enough to fail the no-size-increase test in callSiteInline,

@@ -228,9 +228,9 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
        --   but no more.
 
 -- Experimental thing commented in for now
        --   but no more.
 
 -- Experimental thing commented in for now

-        max_inline_size = case cpr_info of
-                       NoCPRInfo  -> n_val_binders + 2
-                       ReturnsCPR -> n_val_binders + 1
+--        max_inline_size = case cpr_info of
+--                     NoCPRInfo  -> n_val_binders + 2
+--                     ReturnsCPR -> n_val_binders + 1

 
        -- However, the wrapper for a CPR'd function is particularly good to inline,
        -- even in a boring context, because we may get to do update in place:
 
        -- However, the wrapper for a CPR'd function is particularly good to inline,
        -- even in a boring context, because we may get to do update in place:

@@ -624,7 +624,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
                -- Constructors have compulsory unfoldings, but
                -- may have rules, in which case they are 
                -- black listed till later
                -- Constructors have compulsory unfoldings, but
                -- may have rules, in which case they are 
                -- black listed till later

-       CoreUnfolding unf_template is_top is_cheap _ is_bot guidance ->
+       CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance ->

 
     let
        result | yes_or_no = Just unf_template
 
     let
        result | yes_or_no = Just unf_template

@@ -632,8 +632,8 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
 
        n_val_args  = length arg_infos
 
 
        n_val_args  = length arg_infos
 

-       ok_inside_lam = is_cheap || is_bot      -- I'm experimenting with is_cheap
-                                               -- instead of is_value
+       ok_inside_lam = is_value || is_bot || (is_cheap && not is_top)
+                               -- I'm experimenting with is_cheap && not is_top

 
        yes_or_no 
          | black_listed = False
 
        yes_or_no 
          | black_listed = False

@@ -718,6 +718,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
                                   text "occ info:" <+> ppr occ,
                                   text "arg infos" <+> ppr arg_infos,
                                   text "interesting continuation" <+> ppr interesting_cont,
                                   text "occ info:" <+> ppr occ,
                                   text "arg infos" <+> ppr arg_infos,
                                   text "interesting continuation" <+> ppr interesting_cont,

+                                  text "is value:" <+> ppr is_value,

                                   text "is cheap:" <+> ppr is_cheap,
                                   text "is bottom:" <+> ppr is_bot,
                                   text "is top-level:"    <+> ppr is_top,
                                   text "is cheap:" <+> ppr is_cheap,
                                   text "is bottom:" <+> ppr is_bot,
                                   text "is top-level:"    <+> ppr is_top,

diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 5594ece..cf7ed63 100644 (file)
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -432,7 +432,7 @@ opt_UF_UseThreshold         = lookup_def_int "-funfolding-use-threshold"       (8::Int)     --
 opt_UF_ScrutConDiscount                = lookup_def_int "-funfolding-con-discount"        (2::Int)
 opt_UF_FunAppDiscount          = lookup_def_int "-funfolding-fun-discount"        (6::Int)     -- It's great to inline a fn
 opt_UF_PrimArgDiscount         = lookup_def_int "-funfolding-prim-discount"       (1::Int)
 opt_UF_ScrutConDiscount                = lookup_def_int "-funfolding-con-discount"        (2::Int)
 opt_UF_FunAppDiscount          = lookup_def_int "-funfolding-fun-discount"        (6::Int)     -- It's great to inline a fn
 opt_UF_PrimArgDiscount         = lookup_def_int "-funfolding-prim-discount"       (1::Int)

-opt_UF_KeenessFactor           = lookup_def_float "-funfolding-keeness-factor"    (1.0::Float)
+opt_UF_KeenessFactor           = lookup_def_float "-funfolding-keeness-factor"    (1.5::Float)

 
 opt_UF_CheapOp  = ( 1 :: Int)  -- Only one instruction; and the args are charged for
 opt_UF_DearOp   = ( 4 :: Int)
 
 opt_UF_CheapOp  = ( 1 :: Int)  -- Only one instruction; and the args are charged for
 opt_UF_DearOp   = ( 4 :: Int)

diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index f88af6a..e252d73 100644 (file)
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -57,7 +57,7 @@ import NativeInfo       ( os, arch )
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-main =
+main = stderr `seq`    -- Bug fix.  Sigh

  --  _scc_ "main" 
  doIt classifyOpts
 \end{code}
  --  _scc_ "main" 
  doIt classifyOpts
 \end{code}

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index a1f0283..b705f89 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-
 -----------------------------------------------------------------------------
 {-
 -----------------------------------------------------------------------------

-$Id: Parser.y,v 1.28 2000/03/23 17:45:22 simonpj Exp $
+$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $

 
 Haskell grammar.
 
 
 Haskell grammar.
 

@@ -326,7 +326,7 @@ topdecls :: { [RdrBinding] }
        | topdecl                       { [$1] }
 
 topdecl :: { RdrBinding }
        | topdecl                       { [$1] }
 
 topdecl :: { RdrBinding }

-       : srcloc 'type' simpletype '=' type     
+       : srcloc 'type' simpletype '=' sigtype  

                { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
 
        | srcloc 'data' ctype '=' constrs deriving
                { RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
 
        | srcloc 'data' ctype '=' constrs deriving

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index 0f47641..cdaff2e 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -619,6 +619,10 @@ availNames :: AvailInfo -> [Name]
 availNames (Avail n)      = [n]
 availNames (AvailTC n ns) = ns
 
 availNames (Avail n)      = [n]
 availNames (AvailTC n ns) = ns
 

+addSysAvails :: AvailInfo -> [Name] -> AvailInfo
+addSysAvails avail          []  = avail
+addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
+

 filterAvail :: RdrNameIE       -- Wanted
            -> AvailInfo        -- Available
            -> Maybe AvailInfo  -- Resulting available; 
 filterAvail :: RdrNameIE       -- Wanted
            -> AvailInfo        -- Available
            -> Maybe AvailInfo  -- Resulting available; 

diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 6b1b90c..d15cd25 100644 (file)
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -33,7 +33,7 @@ import RdrHsSyn               ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleD
 import RnEnv           ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
                          lookupOccRn, lookupImplicitOccRn,
                          pprAvail,
 import RnEnv           ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
                          lookupOccRn, lookupImplicitOccRn,
                          pprAvail,

-                         availName, availNames, addAvailToNameSet,
+                         availName, availNames, addAvailToNameSet, addSysAvails,

                          FreeVars, emptyFVs
                        )
 import RnMonad
                          FreeVars, emptyFVs
                        )
 import RnMonad

@@ -265,10 +265,15 @@ loadDecl mod decls_map (version, decl)
 
     getDeclSysBinders new_name decl    `thenRn` \ sys_bndrs ->
     let
 
     getDeclSysBinders new_name decl    `thenRn` \ sys_bndrs ->
     let

+       full_avail    = addSysAvails avail sys_bndrs
+               -- Add the sys-binders to avail.  When we import the decl,
+               -- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
+               -- If we miss out sys-binders, we'll read the decl multiple times!
+

        main_name     = availName avail
        new_decls_map = foldl add_decl decls_map
        main_name     = availName avail
        new_decls_map = foldl add_decl decls_map

-                                      [ (name, (version, avail, name==main_name, (mod, decl'))) 
-                                      | name <- sys_bndrs ++ availNames avail]
+                                      [ (name, (version, full_avail, name==main_name, (mod, decl'))) 
+                                      | name <- availNames full_avail]

        add_decl decls_map (name, stuff)
          = WARN( name `elemNameEnv` decls_map, ppr name )
            addToNameEnv decls_map name stuff
        add_decl decls_map (name, stuff)
          = WARN( name `elemNameEnv` decls_map, ppr name )
            addToNameEnv decls_map name stuff

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 1531d8c..982acda 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -49,7 +49,7 @@ import Bag            ( bagToList )
 import List            ( partition, nub )
 import Outputable
 import SrcLoc          ( SrcLoc )
 import List            ( partition, nub )
 import Outputable
 import SrcLoc          ( SrcLoc )

-import CmdLineOpts     ( opt_WarnUnusedMatches )       -- Warn of unused for-all'd tyvars
+import CmdLineOpts     ( opt_GlasgowExts, opt_WarnUnusedMatches )      -- Warn of unused for-all'd tyvars

 import Unique          ( Uniquable(..) )
 import UniqFM          ( lookupUFM )
 import ErrUtils                ( Message )
 import Unique          ( Uniquable(..) )
 import UniqFM          ( lookupUFM )
 import ErrUtils                ( Message )

@@ -159,11 +159,16 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
     bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->
   = pushSrcLocRn src_loc $
     lookupBndrRn name                          `thenRn` \ name' ->
     bindTyVarsFVRn syn_doc tyvars              $ \ tyvars' ->

-    rnHsType syn_doc ty                                `thenRn` \ (ty', ty_fvs) ->
+    rnHsPolyType syn_doc (unquantify ty)       `thenRn` \ (ty', ty_fvs) ->

     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 
     returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
   where
     syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
 

+       -- For H98 we do *not* universally quantify on the RHS of a synonym
+       -- Silently discard context... but the tyvars in the rest won't be in scope
+    unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
+    unquantify ty                                                = ty
+

 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
                tname dname dwname snames src_loc))
   = pushSrcLocRn src_loc $
 rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
                tname dname dwname snames src_loc))
   = pushSrcLocRn src_loc $

@@ -553,7 +558,7 @@ rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars
 
 ---------------------------------------
 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
 
 ---------------------------------------
 rnHsPolyType doc (HsForAllTy Nothing ctxt ty)

-       -- From source code (no kinds on tyvars)
+       -- Implicit quantifiction in source code (no kinds on tyvars)

        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
   = getLocalNameEnv            `thenRn` \ name_env ->
        -- Given the signature  C => T  we universally quantify 
        -- over FV(T) \ {in-scope-tyvars} 
   = getLocalNameEnv            `thenRn` \ name_env ->

diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index ca22634..f95828c 100644 (file)
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -122,6 +122,9 @@ ltLvl (Level maj1 min1) (Level maj2 min2)
 
 ltMajLvl :: Level -> Level -> Bool
     -- Tells if one level belongs to a difft *lambda* level to another
 
 ltMajLvl :: Level -> Level -> Bool
     -- Tells if one level belongs to a difft *lambda* level to another

+    -- But it returns True regardless if l1 is the top level
+    -- We always like to float to the top!     
+ltMajLvl (Level 0 0)    _             = True

 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 
 isTopLvl :: Level -> Bool
 ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
 
 isTopLvl :: Level -> Bool

@@ -202,9 +205,14 @@ lvlExpr _ env (_, AnnVar v)   = returnLvl (lookupVar env v)
 lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)
 
 lvlExpr ctxt_lvl env (_, AnnApp fun arg)
 lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)
 
 lvlExpr ctxt_lvl env (_, AnnApp fun arg)

-  = lvlExpr ctxt_lvl env fun           `thenLvl` \ fun' ->
+  = lvl_fun fun                                `thenLvl` \ fun' ->

     lvlMFE  False ctxt_lvl env arg     `thenLvl` \ arg' ->
     returnLvl (App fun' arg')
     lvlMFE  False ctxt_lvl env arg     `thenLvl` \ arg' ->
     returnLvl (App fun' arg')

+  where
+    lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
+    lvl_fun other             = lvlExpr ctxt_lvl env fun
+       -- We don't do MFE on partial applications generally,
+       -- but we do if the function is big and hairy, like a case

 
 lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
        -- Don't float anything out of an InlineMe
 
 lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
        -- Don't float anything out of an InlineMe

@@ -284,16 +292,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
   |  isUnLiftedType ty                         -- Can't let-bind it
 
 lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
   |  isUnLiftedType ty                         -- Can't let-bind it

-  || not (dest_lvl `ltMajLvl` ctxt_lvl)                -- Does not escape a value lambda
-       -- A decision to float entails let-binding this thing, and we only do 
-       -- that if we'll escape a value lambda.  I considered doing it if it
-       -- would make the thing go to top level, but I found things like
-       --      concat = /\ a -> foldr ..a.. (++) []
-       -- was getting turned into
-       --      concat = /\ a -> lvl a
-       --      lvl    = /\ a -> foldr ..a.. (++) []
-       -- which is pretty stupid.  So for now at least, I don't let-bind things
-       -- simply because they could go to top level.
+  || not good_destination

   || exprIsTrivial expr                                -- Is trivial
   || (strict_ctxt && exprIsBottom expr)                -- Strict context and is bottom
   =    -- Don't float it out
   || exprIsTrivial expr                                -- Is trivial
   || (strict_ctxt && exprIsBottom expr)                -- Strict context and is bottom
   =    -- Don't float it out

@@ -309,6 +308,17 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
     ty       = exprType expr
     dest_lvl = destLevel env fvs (isFunction ann_expr)
     abs_vars = abstractVars dest_lvl env fvs
     ty       = exprType expr
     dest_lvl = destLevel env fvs (isFunction ann_expr)
     abs_vars = abstractVars dest_lvl env fvs

+
+    good_destination =  dest_lvl `ltMajLvl` ctxt_lvl           -- Escapes a value lambda
+                    || (isTopLvl dest_lvl && not strict_ctxt)  -- Goes to the top
+       -- A decision to float entails let-binding this thing, and we only do 
+       -- that if we'll escape a value lambda, or will go to the top level.
+       -- But beware
+       --      concat = /\ a -> foldr ..a.. (++) []
+       -- was getting turned into
+       --      concat = /\ a -> lvl a
+       --      lvl    = /\ a -> foldr ..a.. (++) []
+       -- which is pretty stupid.  Hence the strict_ctxt test

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4999db5..3fee836 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -34,8 +34,9 @@ import Maybes         ( maybeToBool, catMaybes )
 import Name            ( isLocalName, setNameUnique )
 import SimplMonad
 import Type            ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
 import Name            ( isLocalName, setNameUnique )
 import SimplMonad
 import Type            ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,

-                         splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
+                         splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys

                        )
                        )

+import DataCon         ( dataConRepArity )

 import TysPrim         ( statePrimTyCon )
 import Var             ( setVarUnique )
 import VarSet
 import TysPrim         ( statePrimTyCon )
 import Var             ( setVarUnique )
 import VarSet

@@ -247,7 +248,7 @@ analyseCont in_scope cont
     analyse_arg subst (Note _ a)       = analyse_arg subst a
     analyse_arg subst other            = True
 
     analyse_arg subst (Note _ a)       = analyse_arg subst a
     analyse_arg subst other            = True
 

-    interesting_call_context (Stop _)                   = False
+    interesting_call_context (Stop ty)                  = canUpdateInPlace ty

     interesting_call_context (InlinePlease _)           = True
     interesting_call_context (Select _ _ _ _ _)          = True
     interesting_call_context (CoerceIt _ cont)           = interesting_call_context cont
     interesting_call_context (InlinePlease _)           = True
     interesting_call_context (Select _ _ _ _ _)          = True
     interesting_call_context (CoerceIt _ cont)           = interesting_call_context cont

@@ -274,6 +275,20 @@ discardInline :: SimplCont -> SimplCont
 discardInline (InlinePlease cont)  = cont
 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 discardInline cont                = cont
 discardInline (InlinePlease cont)  = cont
 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
 discardInline cont                = cont

+
+-- Consider   let x = <wurble> in ...
+-- If <wurble> returns an explicit constructor, we might be able
+-- to do update in place.  So we treat even a thunk RHS context
+-- as interesting if update in place is possible.  We approximate
+-- this by seeing if the type has a single constructor with a
+-- small arity.  But arity zero isn't good -- we share the single copy
+-- for that case, so no point in sharing.
+
+canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
+                       Just (_, _, [dc]) -> arity == 1 || arity == 2
+                                         where
+                                            arity = dataConRepArity dc
+                       other -> False

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index ba847de..2f88b17 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -226,15 +226,18 @@ simplExprF (App fun arg) cont
     simplExprF fun (ApplyTo NoDup arg se cont)
 
 simplExprF (Case scrut bndr alts) cont
     simplExprF fun (ApplyTo NoDup arg se cont)
 
 simplExprF (Case scrut bndr alts) cont

-  = getSubst                   `thenSmpl` \ subst ->
+  = getSubstEnv                        `thenSmpl` \ subst_env ->

     getSwitchChecker           `thenSmpl` \ chkr ->
     getSwitchChecker           `thenSmpl` \ chkr ->

-    if switchIsOn chkr NoCaseOfCase then
-       -- If case-of-case is off, simply simplify the scrutinee and rebuild
-       simplExprC scrut (Stop (substTy subst (idType bndr)))   `thenSmpl` \ scrut' ->
-       rebuild_case False scrut' bndr alts (substEnv subst) cont
+    if not (switchIsOn chkr NoCaseOfCase) then
+       -- Simplify the scrutinee with a Select continuation
+       simplExprF scrut (Select NoDup bndr alts subst_env cont)
+

     else
     else

-       -- But if it's on, we simplify the scrutinee with a Select continuation
-       simplExprF scrut (Select NoDup bndr alts (substEnv subst) cont)
+       -- If case-of-case is off, simply simplify the case expression
+       -- in a vanilla Stop context, and rebuild the result around it
+       simplExprC scrut (Select NoDup bndr alts subst_env 
+                                (Stop (contResultType cont)))  `thenSmpl` \ case_expr' ->
+       rebuild case_expr' cont

 
 
 simplExprF (Let (Rec pairs) body) cont
 
 
 simplExprF (Let (Rec pairs) body) cont

@@ -694,9 +697,14 @@ wantToExpose :: Int -> CoreExpr -> Bool
 --     v = E
 --     z = \w -> g v w
 -- Which is what we want; chances are z will be inlined now.
 --     v = E
 --     z = \w -> g v w
 -- Which is what we want; chances are z will be inlined now.

+--
+-- This defn isn't quite like 
+--     exprIsCheap (it ignores non-cheap args)
+--     exprIsValue (may not say True for a lone variable)
+-- which is slightly weird

 wantToExpose n (Var v)         = idAppIsCheap v n
 wantToExpose n (Lit l)         = True
 wantToExpose n (Var v)         = idAppIsCheap v n
 wantToExpose n (Lit l)         = True

-wantToExpose n (Lam _ e)       = ASSERT( n==0 ) True   -- We won't have applied \'s
+wantToExpose n (Lam _ e)       = True

 wantToExpose n (Note _ e)      = wantToExpose n e
 wantToExpose n (App f (Type _))        = wantToExpose n f
 wantToExpose n (App f a)       = wantToExpose (n+1) f
 wantToExpose n (Note _ e)      = wantToExpose n e
 wantToExpose n (App f (Type _))        = wantToExpose n f
 wantToExpose n (App f a)       = wantToExpose (n+1) f

@@ -737,10 +745,13 @@ simplVar var cont
 
 completeCall var occ cont
   = getBlackList       `thenSmpl` \ black_list_fn ->
 
 completeCall var occ cont
   = getBlackList       `thenSmpl` \ black_list_fn ->

-    getSwitchChecker   `thenSmpl` \ chkr ->

     getInScope         `thenSmpl` \ in_scope ->
     getInScope         `thenSmpl` \ in_scope ->

+    getSwitchChecker   `thenSmpl` \ chkr ->

     let
     let

-       black_listed                               = black_list_fn var
+       dont_use_rules     = switchIsOn chkr DontApplyRules
+       no_case_of_case    = switchIsOn chkr NoCaseOfCase
+       black_listed       = black_list_fn var
+

        (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
        discard_inline_cont | inline_call = discardInline cont
                            | otherwise   = cont
        (arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
        discard_inline_cont | inline_call = discardInline cont
                            | otherwise   = cont

@@ -772,10 +783,10 @@ completeCall var occ cont
        -- won't occur for things that have specialisations till a later phase, so
        -- it's ok to try for inlining first.
 
        -- won't occur for things that have specialisations till a later phase, so
        -- it's ok to try for inlining first.
 

-    prepareArgs (switchIsOn chkr NoCaseOfCase) var cont        $ \ args' cont' ->
+    prepareArgs no_case_of_case var cont       $ \ args' cont' ->

     let
     let

-       maybe_rule | switchIsOn chkr DontApplyRules = Nothing
-                  | otherwise                      = lookupRule in_scope var args' 
+       maybe_rule | dont_use_rules = Nothing
+                  | otherwise      = lookupRule in_scope var args' 

     in
     case maybe_rule of {
        Just (rule_name, rule_rhs) -> 
     in
     case maybe_rule of {
        Just (rule_name, rule_rhs) -> 

@@ -1026,7 +1037,7 @@ rebuild expr (InlinePlease cont)
   = rebuild (Note InlineCall expr) cont
 
 rebuild scrut (Select _ bndr alts se cont)
   = rebuild (Note InlineCall expr) cont
 
 rebuild scrut (Select _ bndr alts se cont)

-  = rebuild_case True scrut bndr alts se cont
+  = rebuild_case scrut bndr alts se cont

 \end{code}
 
 Case elimination [see the code above]
 \end{code}
 
 Case elimination [see the code above]

@@ -1114,7 +1125,7 @@ Blob of helper functions for the "case-of-something-else" situation.
 ---------------------------------------------------------
 --     Eliminate the case if possible
 
 ---------------------------------------------------------
 --     Eliminate the case if possible
 

-rebuild_case add_eval_info scrut bndr alts se cont
+rebuild_case scrut bndr alts se cont

   | maybeToBool maybe_con_app
   = knownCon scrut (DataAlt con) args bndr alts se cont
 
   | maybeToBool maybe_con_app
   = knownCon scrut (DataAlt con) args bndr alts se cont
 

@@ -1127,7 +1138,7 @@ rebuild_case add_eval_info scrut bndr alts se cont
     simplExprF (head (rhssOfAlts alts)) cont)
 
   | otherwise
     simplExprF (head (rhssOfAlts alts)) cont)
 
   | otherwise

-  = complete_case add_eval_info scrut bndr alts se cont
+  = complete_case scrut bndr alts se cont

 
   where
     maybe_con_app    = analyse (collectArgs scrut)
 
   where
     maybe_con_app    = analyse (collectArgs scrut)

@@ -1192,7 +1203,7 @@ canEliminateCase scrut bndr alts
 ---------------------------------------------------------
 --     Case of something else
 
 ---------------------------------------------------------
 --     Case of something else
 

-complete_case add_eval_info scrut case_bndr alts se cont
+complete_case scrut case_bndr alts se cont

   =    -- Prepare case alternatives
     prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
                    impossible_cons alts                `thenSmpl` \ better_alts ->
   =    -- Prepare case alternatives
     prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
                    impossible_cons alts                `thenSmpl` \ better_alts ->

@@ -1206,7 +1217,10 @@ complete_case add_eval_info scrut case_bndr alts se cont
        
 
        -- Deal with variable scrutinee
        
 
        -- Deal with variable scrutinee

-    (  simplCaseBinder add_eval_info scrut case_bndr   $ \ case_bndr' zap_occ_info ->
+    (  
+        getSwitchChecker                               `thenSmpl` \ chkr ->
+       simplCaseBinder (switchIsOn chkr NoCaseOfCase)
+                       scrut case_bndr                 $ \ case_bndr' zap_occ_info ->

 
        -- Deal with the case alternatives
        simplAlts zap_occ_info impossible_cons
 
        -- Deal with the case alternatives
        simplAlts zap_occ_info impossible_cons

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index d9dc3a2..b52ef1f 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -30,7 +30,7 @@ import TcEnv          ( tcExtendLocalValEnv,
                        )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
 import TcImprove       ( tcImprove )
                        )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
 import TcImprove       ( tcImprove )

-import TcMonoType      ( tcHsType, checkSigTyVars,
+import TcMonoType      ( tcHsSigType, checkSigTyVars,

                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
 import TcPat           ( tcPat )
                          TcSigInfo(..), tcTySig, maybeSig, sigCtxt
                        )
 import TcPat           ( tcPat )

@@ -857,7 +857,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
     tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
 
        -- Get and instantiate its alleged specialised type
     tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
 
        -- Get and instantiate its alleged specialised type

-    tcHsType poly_ty                           `thenTc` \ sig_ty ->
+    tcHsSigType poly_ty                                `thenTc` \ sig_ty ->

 
        -- Check that f has a more general type, and build a RHS for
        -- the spec-pragma-id at the same time
 
        -- Check that f has a more general type, and build a RHS for
        -- the spec-pragma-id at the same time

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index ccfd18a..3c39da1 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -33,7 +33,7 @@ import TcEnv          ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
 import TcBinds         ( tcBindWithSigs, tcSpecSigs )
 import TcUnify         ( unifyKinds )
 import TcMonad
 import TcBinds         ( tcBindWithSigs, tcSpecSigs )
 import TcUnify         ( unifyKinds )
 import TcMonad

-import TcMonoType      ( tcHsType, tcHsTopType, tcExtendTopTyVarScope, 
+import TcMonoType      ( kcHsType, tcHsTopType, tcExtendTopTyVarScope, 

                          tcContext, checkSigTyVars, sigCtxt, mkTcSig
                        )
 import TcSimplify      ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
                          tcContext, checkSigTyVars, sigCtxt, mkTcSig
                        )
 import TcSimplify      ( tcSimplifyAndCheck, bindInstsOfLocalFuns )

@@ -128,7 +128,7 @@ kcClassDecl (ClassDecl      context class_name
   where
     the_class_sigs = filter isClassOpSig class_sigs
   
   where
     the_class_sigs = filter isClassOpSig class_sigs
   

-    kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
+    kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty)

 \end{code}
 
 
 \end{code}
 
 

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 9ab1460..f622d1c 100644 (file)
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -35,7 +35,7 @@ import TcEnv          ( tcInstId,
                          tcLookupTyCon, tcLookupDataCon
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )
                          tcLookupTyCon, tcLookupDataCon
                        )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcStmts )

-import TcMonoType      ( tcHsType, checkSigTyVars, sigCtxt )
+import TcMonoType      ( tcHsSigType, checkSigTyVars, sigCtxt )

 import TcPat           ( badFieldCon )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
 import TcType          ( TcType, TcTauType,
 import TcPat           ( badFieldCon )
 import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
 import TcType          ( TcType, TcTauType,

@@ -699,7 +699,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = tcSetErrCtxt (exprSigCtxt in_expr)  $
 \begin{code}
 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
  = tcSetErrCtxt (exprSigCtxt in_expr)  $

-   tcHsType  poly_ty           `thenTc` \ sig_tc_ty ->
+   tcHsSigType  poly_ty                `thenTc` \ sig_tc_ty ->

 
    if not (isForAllTy sig_tc_ty) then
        -- Easy case
 
    if not (isForAllTy sig_tc_ty) then
        -- Easy case

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index b87355d..37b7036 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -51,7 +51,6 @@ import TcMonad
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )
 import TcType  ( TcType, TcTyVar,
                  zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
                )

-import TyCon   ( isDataTyCon )

 import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
 import Name    ( isLocallyDefined )
 import Var     ( TyVar )
 import Type    ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
 import Name    ( isLocallyDefined )
 import Var     ( TyVar )

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 0c32116..0d9ffac 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -49,7 +49,7 @@ import NameSet                ( emptyNameSet )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprConstraint )
 import SrcLoc          ( SrcLoc )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprConstraint )
 import SrcLoc          ( SrcLoc )

-import TyCon           ( isSynTyCon, isDataTyCon, tyConDerivings )
+import TyCon           ( isSynTyCon, tyConDerivings )

 import Type            ( Type, isUnLiftedType, mkTyVarTys,
                          splitSigmaTy, isTyVarTy,
                          splitTyConApp_maybe, splitDictTy_maybe,
 import Type            ( Type, isUnLiftedType, mkTyVarTys,
                          splitSigmaTy, isTyVarTy,
                          splitTyConApp_maybe, splitDictTy_maybe,

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 484aa3c..e213632 100644 (file)
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -19,7 +19,7 @@ import RnHsSyn                ( RenamedMatch, RenamedGRHSs, RenamedStmt )
 import TcHsSyn         ( TcMatch, TcGRHSs, TcStmt )
 
 import TcMonad
 import TcHsSyn         ( TcMatch, TcGRHSs, TcStmt )
 
 import TcMonad

-import TcMonoType      ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
+import TcMonoType      ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )

 import Inst            ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
 import TcEnv           ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
 import TcPat           ( tcPat, tcPatBndr_NoSigs, polyPatSig )
 import Inst            ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
 import TcEnv           ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
 import TcPat           ( tcPat, tcPatBndr_NoSigs, polyPatSig )

@@ -175,7 +175,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
        -- STEP 3: Unify with the rhs type signature if any
        (case maybe_rhs_sig of
            Nothing  -> returnTc ()
        -- STEP 3: Unify with the rhs type signature if any
        (case maybe_rhs_sig of
            Nothing  -> returnTc ()

-           Just sig -> tcHsType sig    `thenTc` \ sig_ty ->
+           Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->

 
                        -- Check that the signature isn't a polymorphic one, which
                        -- we don't permit (at present, anyway)
 
                        -- Check that the signature isn't a polymorphic one, which
                        -- we don't permit (at present, anyway)

diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs
index 1d6087c..af02410 100644 (file)
--- a/ghc/compiler/typecheck/TcMonoType.lhs
+++ b/ghc/compiler/typecheck/TcMonoType.lhs
@@ -4,8 +4,8 @@
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
 
 \begin{code}
 \section[TcMonoType]{Typechecking user-specified @MonoTypes@}
 
 \begin{code}

-module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
-                   tcContext, tcHsTyVar, kcHsTyVar,
+module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
+                   tcContext, tcHsTyVar, kcHsTyVar, kcHsType,

                    tcExtendTyVarScope, tcExtendTopTyVarScope,
                    TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
                    checkSigTyVars, sigCtxt, sigPatCtxt
                    tcExtendTyVarScope, tcExtendTopTyVarScope,
                    TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
                    checkSigTyVars, sigCtxt, sigPatCtxt

@@ -32,7 +32,7 @@ import Inst           ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
 import TcUnify         ( unifyKind, unifyKinds, unifyTypeKind )
 import Type            ( Type, PredType(..), ThetaType, UsageAnn(..),
                          mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
 import TcUnify         ( unifyKind, unifyKinds, unifyTypeKind )
 import Type            ( Type, PredType(..), ThetaType, UsageAnn(..),
                          mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,

-                          mkUsForAllTy, zipFunTys,
+                          mkUsForAllTy, zipFunTys, hoistForAllTys,

                          mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp,
                          mkAppTys, splitForAllTys, splitRhoTy,
                          boxedTypeKind, unboxedTypeKind, tyVarsOfType,
                          mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp,
                          mkAppTys, splitForAllTys, splitRhoTy,
                          boxedTypeKind, unboxedTypeKind, tyVarsOfType,

@@ -72,6 +72,18 @@ tcHsType and tcHsTypeKind
 tcHsType checks that the type really is of kind Type!
 
 \begin{code}
 tcHsType checks that the type really is of kind Type!
 
 \begin{code}

+kcHsType :: RenamedHsType -> TcM c ()
+  -- Kind-check the type
+kcHsType ty = tc_type ty       `thenTc_`
+             returnTc ()
+
+tcHsSigType :: RenamedHsType -> TcM s TcType
+  -- Used for type sigs written by the programmer
+  -- Hoist any inner for-alls to the top
+tcHsSigType ty
+  = tcHsType ty                `thenTc` \ ty' ->
+    returnTc (hoistForAllTys ty')
+

 tcHsType :: RenamedHsType -> TcM s TcType
 tcHsType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
 tcHsType :: RenamedHsType -> TcM s TcType
 tcHsType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $

@@ -100,20 +112,22 @@ tcHsTopType :: RenamedHsType -> TcM s Type
 tcHsTopType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type ty                         `thenTc` \ ty' ->
 tcHsTopType ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type ty                         `thenTc` \ ty' ->

-    forkNF_Tc (zonkTcTypeToType ty')
+    forkNF_Tc (zonkTcTypeToType ty')   `thenTc` \ ty'' ->
+    returnTc (hoistForAllTys ty'')
+
+tcHsTopBoxedType :: RenamedHsType -> TcM s Type
+tcHsTopBoxedType ty
+  = -- tcAddErrCtxt (typeCtxt ty)              $
+    tc_boxed_type ty                   `thenTc` \ ty' ->
+    forkNF_Tc (zonkTcTypeToType ty')   `thenTc` \ ty'' ->
+    returnTc (hoistForAllTys ty'')

 
 tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
 tcHsTopTypeKind ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type_kind ty                            `thenTc` \ (kind, ty') ->
     forkNF_Tc (zonkTcTypeToType ty')           `thenTc` \ zonked_ty ->
 
 tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
 tcHsTopTypeKind ty
   = -- tcAddErrCtxt (typeCtxt ty)              $
     tc_type_kind ty                            `thenTc` \ (kind, ty') ->
     forkNF_Tc (zonkTcTypeToType ty')           `thenTc` \ zonked_ty ->

-    returnNF_Tc (kind, zonked_ty)
-
-tcHsTopBoxedType :: RenamedHsType -> TcM s Type
-tcHsTopBoxedType ty
-  = -- tcAddErrCtxt (typeCtxt ty)              $
-    tc_boxed_type ty                   `thenTc` \ ty' ->
-    forkNF_Tc (zonkTcTypeToType ty')
+    returnNF_Tc (kind, hoistForAllTys zonked_ty)

 \end{code}
 
 
 \end{code}
 
 

@@ -415,7 +429,7 @@ tcTySig :: RenamedSig -> TcM s TcSigInfo
 
 tcTySig (Sig v ty src_loc)
  = tcAddSrcLoc src_loc $
 
 tcTySig (Sig v ty src_loc)
  = tcAddSrcLoc src_loc $

-   tcHsType ty                                 `thenTc` \ sigma_tc_ty ->
+   tcHsSigType ty                              `thenTc` \ sigma_tc_ty ->

    mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> 
    returnTc sig
 
    mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> 
    returnTc sig
 

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 7974073..88914ac 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -25,7 +25,7 @@ import TcEnv          ( tcLookupValue, tcLookupClassByKey,
                          tcLookupValueByKey, newLocalId, badCon
                        )
 import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
                          tcLookupValueByKey, newLocalId, badCon
                        )
 import TcType          ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )

-import TcMonoType      ( tcHsType )
+import TcMonoType      ( tcHsSigType )

 import TcUnify                 ( unifyTauTy, unifyListTy,
                          unifyTupleTy, unifyUnboxedTupleTy
                        )
 import TcUnify                 ( unifyTauTy, unifyListTy,
                          unifyTupleTy, unifyUnboxedTupleTy
                        )

@@ -142,7 +142,7 @@ tcPat tc_bndr (ParPatIn parend_pat) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
 tcPat tc_bndr (SigPatIn pat sig) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
 tcPat tc_bndr (SigPatIn pat sig) pat_ty

-  = tcHsType sig                                       `thenTc` \ sig_ty ->
+  = tcHsSigType sig                                    `thenTc` \ sig_ty ->

 
        -- Check that the signature isn't a polymorphic one, which
        -- we don't permit (at present, anyway)
 
        -- Check that the signature isn't a polymorphic one, which
        -- we don't permit (at present, anyway)

diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs
index c5cdf0c..1d9edb8 100644 (file)
--- a/ghc/compiler/typecheck/TcRules.lhs
+++ b/ghc/compiler/typecheck/TcRules.lhs
@@ -16,7 +16,7 @@ import TcMonad
 import TcSimplify      ( tcSimplifyToDicts, tcSimplifyAndCheck )
 import TcType          ( zonkTcTypes, newTyVarTy_OpenKind )
 import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )
 import TcSimplify      ( tcSimplifyToDicts, tcSimplifyAndCheck )
 import TcType          ( zonkTcTypes, newTyVarTy_OpenKind )
 import TcIfaceSig      ( tcCoreExpr, tcCoreLamBndrs, tcVar )

-import TcMonoType      ( tcHsType, tcHsTyVar, checkSigTyVars )
+import TcMonoType      ( tcHsSigType, tcHsTyVar, checkSigTyVars )

 import TcExpr          ( tcExpr )
 import TcEnv           ( tcExtendLocalValEnv, newLocalId,
                          tcExtendTyVarEnv
 import TcExpr          ( tcExpr )
 import TcEnv           ( tcExtendLocalValEnv, newLocalId,
                          tcExtendTyVarEnv

@@ -104,7 +104,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc)
   where
     new_id (RuleBndr var)         = newTyVarTy_OpenKind        `thenNF_Tc` \ ty ->
                                     returnNF_Tc (mkVanillaId var ty)
   where
     new_id (RuleBndr var)         = newTyVarTy_OpenKind        `thenNF_Tc` \ ty ->
                                     returnNF_Tc (mkVanillaId var ty)

-    new_id (RuleBndrSig var rn_ty) = tcHsType rn_ty    `thenTc` \ ty ->
+    new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->

                                     returnNF_Tc (mkVanillaId var ty)
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> 
                                     returnNF_Tc (mkVanillaId var ty)
 
 ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> 

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 73282fe..88b7428 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -374,7 +374,3 @@ pp_cycle str decls
      where
         name = tyClDeclName decl
 \end{code}
      where
         name = tyClDeclName decl
 \end{code}

-
-
-
-

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 78c6f32..4508cb0 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -21,7 +21,7 @@ import TcHsSyn                ( TcMonoBinds, idsToMonoBinds )
 import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonoType      ( tcExtendTopTyVarScope, tcExtendTyVarScope, 
 import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonoType      ( tcExtendTopTyVarScope, tcExtendTyVarScope, 

-                         tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
+                         tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,

                          tcContext, tcHsTopTypeKind
                        )
 import TcType          ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
                          tcContext, tcHsTopTypeKind
                        )
 import TcType          ( zonkTcTyVarToTyVar, zonkTcClassConstraints )

@@ -35,18 +35,16 @@ import DataCon              ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
                          markedStrict, notMarkedStrict, markedUnboxed
                        )
 import MkId            ( mkDataConId, mkDataConWrapId, mkRecordSelId )
                          markedStrict, notMarkedStrict, markedUnboxed
                        )
 import MkId            ( mkDataConId, mkDataConWrapId, mkRecordSelId )

-import Id              ( idUnfolding )
-import CoreUnfold      ( unfoldingTemplate )

 import FieldLabel
 import Var             ( Id, TyVar )
 import Name            ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
 import Outputable
 import FieldLabel
 import Var             ( Id, TyVar )
 import Name            ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
 import Outputable

-import TyCon           ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, 
+import TyCon           ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, 

                          isSynTyCon, tyConDataCons, isNewTyCon
                        )
 import Type            ( getTyVar, tyVarsOfTypes,
                          mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
                          isSynTyCon, tyConDataCons, isNewTyCon
                        )
 import Type            ( getTyVar, tyVarsOfTypes,
                          mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,

-                         mkTyVarTy,
+                         mkTyVarTy, splitForAllTys, isForAllTy,

                          mkArrowKind, mkArrowKinds, boxedTypeKind,
                          isUnboxedType, Type, ThetaType, classesOfPreds
                        )
                          mkArrowKind, mkArrowKinds, boxedTypeKind,
                          isUnboxedType, Type, ThetaType, classesOfPreds
                        )

@@ -54,6 +52,7 @@ import Var            ( tyVarKind )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import Util            ( equivClasses )
 import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import Util            ( equivClasses )
 import FiniteMap        ( FiniteMap, lookupWithDefaultFM )

+import CmdLineOpts     ( opt_GlasgowExts )

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -88,12 +87,12 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc)
   where
     kc_con (VanillaCon btys)    = mapTc kc_bty btys            `thenTc_` returnTc ()
     kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2]     `thenTc_` returnTc ()
   where
     kc_con (VanillaCon btys)    = mapTc kc_bty btys            `thenTc_` returnTc ()
     kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2]     `thenTc_` returnTc ()

-    kc_con (NewCon ty _)        = tcHsType ty                  `thenTc_` returnTc ()
+    kc_con (NewCon ty _)        = kcHsType ty

     kc_con (RecCon flds)        = mapTc kc_field flds          `thenTc_` returnTc ()
 
     kc_con (RecCon flds)        = mapTc kc_field flds          `thenTc_` returnTc ()
 

-    kc_bty (Banged ty)   = tcHsType ty
-    kc_bty (Unbanged ty) = tcHsType ty
-    kc_bty (Unpacked ty) = tcHsType ty
+    kc_bty (Banged ty)   = kcHsType ty
+    kc_bty (Unbanged ty) = kcHsType ty
+    kc_bty (Unpacked ty) = kcHsType ty

 
     kc_field (_, bty)    = kc_bty bty
 \end{code}
 
     kc_field (_, bty)    = kc_bty bty
 \end{code}

@@ -112,6 +111,10 @@ tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
   = tcLookupTy tycon_name                              `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
     tcExtendTopTyVarScope tycon_kind tyvar_names       $ \ tyvars _ ->
     tcHsTopTypeKind rhs                                        `thenTc` \ (_, rhs_ty) ->
   = tcLookupTy tycon_name                              `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
     tcExtendTopTyVarScope tycon_kind tyvar_names       $ \ tyvars _ ->
     tcHsTopTypeKind rhs                                        `thenTc` \ (_, rhs_ty) ->

+       -- If the RHS mentions tyvars that aren't in scope, we'll 
+       -- quantify over them.  With gla-exts that's right, but for H98
+       -- we should complain. We can't do that here without falling into
+       -- a black hole, so we do it in rnDecl (TySynonym case)

     let
        -- Construct the tycon
         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
     let
        -- Construct the tycon
         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 33d59ba..9d15297 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -41,10 +41,10 @@ module Type (
        repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
 
         UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
        repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
 
         UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,

-        mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
+        mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy, 

 
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 
 
        mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, 

-       isForAllTy, applyTy, applyTys, mkPiType,
+       isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,

 
        TauType, RhoType, SigmaType, PredType(..), ThetaType,
        ClassPred, ClassContext, mkClassPred,
 
        TauType, RhoType, SigmaType, PredType(..), ThetaType,
        ClassPred, ClassContext, mkClassPred,

@@ -670,6 +670,22 @@ Note that we allow applications to be of usage-annotated- types, as an
 extension: we handle them by lifting the annotation outside.  The
 argument, however, must still be unannotated.
 
 extension: we handle them by lifting the annotation outside.  The
 argument, however, must still be unannotated.
 

+\begin{code}
+hoistForAllTys :: Type -> Type
+       -- Move all the foralls to the top
+       -- e.g.  T -> forall a. a  ==>   forall a. T -> a
+hoistForAllTys ty
+  = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
+  where
+    hoist :: Type -> ([TyVar], Type)
+    hoist ty = case splitFunTys    ty  of { (args, res) -> 
+              case splitForAllTys res of {
+                 ([], body)  -> ([], ty) ;
+                 (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
+                                  (tvs1 ++ tvs2, mkFunTys args body2)
+              }}}
+\end{code}
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *