Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc into unboxed-tuple-argumentsunboxed-tuple-arguments

16 files changed, 183 insertions, 134 deletions

diff --git a/aclocal.m4 b/aclocal.m4
index 05470196dd..6d80ad3759 100644
--- a/aclocal.m4
+++ b/aclocal.m4
@@ -223,7 +223,10 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
         netbsd)
             test -z "[$]2" || eval "[$]2=OSNetBSD"
             ;;
-        dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku)
+        haiku)
+            test -z "[$]2" || eval "[$]2=OSHaiku"
+            ;;
+        dragonfly|osf1|osf3|hpux|linuxaout|freebsd2|cygwin32|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix)
             test -z "[$]2" || eval "[$]2=OSUnknown"
             ;;
         *)
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 930041dea4..96a1abdcbe 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -863,7 +863,7 @@ tryUnfolding dflags id lone_variable
 			-- uf_arity will typically be equal to (idArity id), 
 			-- but may be less for InlineRules
  | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags
- = pprTrace ("Considering inlining: " ++ showSDoc (ppr id))
+ = pprTrace ("Considering inlining: " ++ showSDocDump (ppr id))
 		 (vcat [text "arg infos" <+> ppr arg_infos,
 			text "uf arity" <+> ppr uf_arity,
 			text "interesting continuation" <+> ppr cont_info,
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 09ab98fff1..4f94a1c3e9 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -153,8 +153,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
                    , abs_exports = exports, abs_ev_binds = ev_binds
                    , abs_binds = binds })
+         -- See Note [Desugaring AbsBinds]
   = do  { bind_prs    <- ds_lhs_binds binds
-        ; let core_bind = Rec (fromOL bind_prs)
+        ; let core_bind = Rec [ makeCorePair (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- fromOL bind_prs ]
 	      	-- Monomorphic recursion possible, hence Rec
 
 	      tup_expr     = mkBigCoreVarTup locals
@@ -176,13 +178,28 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
 			         mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
                            rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
 		     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
-		     ; let global' = addIdSpecialisations global rules
+		     ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.  
 		     ; return ((global', rhs) `consOL` spec_binds) }
 
         ; export_binds_s <- mapM mk_bind exports
 
 	; return ((poly_tup_id, poly_tup_rhs) `consOL` 
 		    concatOL export_binds_s) }
+  where
+    inline_env :: IdEnv Id   -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                          | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                          , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id `orElse` lcl_id
 
 ------------------------
 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
@@ -219,6 +236,16 @@ dictArity :: [Var] -> Arity
 dictArity dicts = count isId dicts
 \end{code}
 
+[Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
 Note [Rules and inlining]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Common special case: no type or dictionary abstraction
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index bb8b337a00..f756578e2d 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -175,12 +175,12 @@ data HsBindLR idL idR
         --  of this last construct.)
 
 data ABExport id
-  = ABE { abe_poly  :: id
+  = ABE { abe_poly  :: id           -- Any INLINE pragmas is attached to this Id
         , abe_mono  :: id
-        , abe_wrap  :: HsWrapper  -- See Note [AbsBinds wrappers]
+        , abe_wrap  :: HsWrapper    -- See Note [AbsBinds wrappers]
              -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
-        , abe_prags :: TcSpecPrags }
-  deriving (Data, Typeable)
+        , abe_prags :: TcSpecPrags  -- SPECIALISE pragmas
+  } deriving (Data, Typeable)
 
 placeHolderNames :: NameSet
 -- Used for the NameSet in FunBind and PatBind prior to the renamer
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index a1cd558bc0..0de092742c 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -1283,8 +1283,13 @@ tcIfaceGlobal name
 -- emasculated form (e.g. lacking data constructors).
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
-                                 ; return (tyThingTyCon thing) }
+tcIfaceTyCon (IfaceTc name) 
+  = do { thing <- tcIfaceGlobal name
+       ; case thing of    -- A "type constructor" can be a promoted data constructor
+                          --           c.f. Trac #5881
+           ATyCon   tc -> return tc
+           ADataCon dc -> return (buildPromotedDataCon dc)
+           _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
 
 tcIfaceCoAxiom :: Name -> IfL CoAxiom
 tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index fab7600c01..488df37a79 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1176,14 +1176,17 @@ runPhase As input_fn dflags
                         = do
                             llvmVer <- io $ figureLlvmVersion dflags
                             return $ case llvmVer of
-                                Just n | n >= 30 -> SysTools.runClang
-                                _                -> SysTools.runAs
+                                -- using cGccLinkerOpts here but not clear if
+                                -- opt_c isn't a better choice
+                                Just n | n >= 30 ->
+                                    (SysTools.runClang, cGccLinkerOpts)
+
+                                _ -> (SysTools.runAs, getOpts dflags opt_a)
 
                         | otherwise
-                        = return SysTools.runAs
+                        = return (SysTools.runAs, getOpts dflags opt_a)
 
-        as_prog <- whichAsProg
-        let as_opts = getOpts dflags opt_a
+        (as_prog, as_opts) <- whichAsProg
         let cmdline_include_paths = includePaths dflags
 
         next_phase <- maybeMergeStub
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 34afd5ca0e..01de9af4ee 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -309,6 +309,9 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
               ; omit_prags = dopt Opt_OmitInterfacePragmas dflags
               ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
               ; th         = xopt Opt_TemplateHaskell      dflags
+              ; data_kinds = xopt Opt_DataKinds            dflags
+              ; no_trim_types = th || data_kinds  
+                                -- See Note [When we can't trim types]
               }
         ; showPass dflags CoreTidy
 
@@ -334,7 +337,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 	      ; final_ids  = [ id | id <- bindersOfBinds tidy_binds, 
 				    isExternalName (idName id)]
 
-              ; tidy_type_env = tidyTypeEnv omit_prags th export_set
+              ; tidy_type_env = tidyTypeEnv omit_prags no_trim_types export_set
                                       (extendTypeEnvWithIds type_env final_ids)
 
               ; tidy_insts    = tidyInstances (lookup_dfun tidy_type_env) insts
@@ -410,7 +413,7 @@ lookup_dfun type_env dfun_id
 
 --------------------------
 tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
-            -> Bool       -- Template Haskell is on
+            -> Bool       -- Type-trimming flag
             -> NameSet -> TypeEnv -> TypeEnv
 
 -- The competed type environment is gotten from
@@ -423,11 +426,11 @@ tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
 -- This truncates the type environment to include only the 
 -- exported Ids and things needed from them, which saves space
 
-tidyTypeEnv omit_prags th exports type_env
+tidyTypeEnv omit_prags no_trim_types exports type_env
  = let
         type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
           -- (1) remove wired-in things
-        type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1
+        type_env2 | omit_prags = mapNameEnv (trimThing no_trim_types exports) type_env1
                   | otherwise  = type_env1
           -- (2) trimmed if necessary
     in
@@ -436,9 +439,9 @@ tidyTypeEnv omit_prags th exports type_env
 --------------------------
 trimThing :: Bool -> NameSet -> TyThing -> TyThing
 -- Trim off inessentials, for boot files and no -O
-trimThing th exports (ATyCon tc)
-   | not th && not (mustExposeTyCon exports tc)
-   = ATyCon (makeTyConAbstract tc)	-- Note [Trimming and Template Haskell]
+trimThing no_trim_types exports (ATyCon tc)
+   | not (mustExposeTyCon no_trim_types exports tc)
+   = ATyCon (makeTyConAbstract tc)	-- Note [When we can't trim types]
 
 trimThing _th _exports (AnId id)
    | not (isImplicitId id) 
@@ -448,30 +451,61 @@ trimThing _th _exports other_thing
   = other_thing
 
 
-{- Note [Trimming and Template Haskell]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (Trac #2386) this
+{- Note [When we can't trim types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of type trimming is to export algebraic data types
+abstractly (without their data constructors) when compiling without
+-O, unless of course they are explicitly exported by the user.  
+
+We always export synonyms, because they can be mentioned in the type
+of an exported Id.  We could do a full dependency analysis starting
+from the explicit exports, but that's quite painful, and not done for
+now.
+
+But there are some times we can't do that, indicated by the 'no_trim_types' flag.
+
+First, Template Haskell.  Consider (Trac #2386) this
 	module M(T, makeOne) where
 	  data T = Yay String
 	  makeOne = [| Yay "Yep" |]
 Notice that T is exported abstractly, but makeOne effectively exports it too!
 A module that splices in $(makeOne) will then look for a declartion of Yay,
 so it'd better be there.  Hence, brutally but simply, we switch off type
-constructor trimming if TH is enabled in this module. -}
-
-
-mustExposeTyCon :: NameSet	-- Exports
+constructor trimming if TH is enabled in this module.
+
+Second, data kinds.  Consider (Trac #5912) 
+     {-# LANGUAGE DataKinds #-}
+     module M() where
+     data UnaryTypeC a = UnaryDataC a
+     type Bug = 'UnaryDataC
+We always export synonyms, so Bug is exposed, and that means that
+UnaryTypeC must be too, even though it's not explicitly exported.  In
+effect, DataKinds means that we'd need to do a full dependency analysis
+to see what data constructors are mentioned.  But we don't do that yet.
+
+In these two cases we just switch off type trimming altogether.
+ -}
+
+mustExposeTyCon :: Bool         -- Type-trimming flag 
+                -> NameSet	-- Exports
 		-> TyCon	-- The tycon
 		-> Bool 	-- Can its rep be hidden?
 -- We are compiling without -O, and thus trying to write as little as 
 -- possible into the interface file.  But we must expose the details of
 -- any data types whose constructors or fields are exported
-mustExposeTyCon exports tc
-  | not (isAlgTyCon tc) 	-- Synonyms
+mustExposeTyCon no_trim_types exports tc
+  | no_trim_types               -- See Note [When we can't trim types]
+  = True
+
+  | not (isAlgTyCon tc) 	-- Always expose synonyms (otherwise we'd have to
+                                -- figure out whether it was mentioned in the type
+                                -- of any other exported thing)
   = True
+
   | isEnumerationTyCon tc	-- For an enumeration, exposing the constructors
   = True			-- won't lead to the need for further exposure
 				-- (This includes data types with no constructors.)
+
   | isFamilyTyCon tc		-- Open type family
   = True
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 162ce22775..d0302a19a2 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -502,7 +502,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
       = return []
     rn_dotdot (Just {}) Nothing _flds   -- ".." on record update
       = do { addErr (badDotDot ctxt); return [] }
-    rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat
+    rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
       = ASSERT( n == length flds )
         do { loc <- getSrcSpanM	-- Rather approximate
            ; dd_flag <- xoptM Opt_RecordWildCards
@@ -526,11 +526,11 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
                    where
                      rdr = mkRdrUnqual (nameOccName fld)
 
-                 dot_dot_gres = [ gre 
+                 dot_dot_gres = [ head gres
                                 | fld <- con_fields
                                 , not (fld `elem` present_flds)
-                                , let gres@(gre:_) = lookupGRE_Name rdr_env fld
-                                , not (null gres)
+                                , let gres = lookupGRE_Name rdr_env fld
+                                , not (null gres)  -- Check field is in scope
                                 , case ctxt of
                                     HsRecFieldCon {} -> arg_in_scope fld
                                     _other           -> True ] 
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 829c2ca40f..4af626d053 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -137,7 +137,7 @@ showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
 
 endPass :: DynFlags -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
 endPass dflags pass binds rules
-  = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules
+  = do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules
        ; lintPassResult dflags pass binds }      
   where
     mb_flag = case coreDumpFlag pass of
@@ -167,9 +167,9 @@ dumpPassResult dflags mb_flag hdr extra_info binds rules
 	  -- This has the side effect of forcing the intermediate to be evaluated
 
   where
-    dump_doc  = vcat [ text "Result size =" <+> int (coreBindsSize binds)
-                     , extra_info
-		     , blankLine
+    dump_doc  = vcat [ nest 2 extra_info
+		     , nest 2 (text "Result size =" <+> int (coreBindsSize binds))
+                     , blankLine
                      , pprCoreBindings binds 
                      , ppUnless (null rules) pp_rules ]
     pp_rules = vcat [ blankLine
@@ -307,7 +307,8 @@ instance Outputable CoreToDo where
   ppr (CoreDoPasses {})        = ptext (sLit "CoreDoPasses")
 
 pprPassDetails :: CoreToDo -> SDoc
-pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n
+pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n 
+                                            , ppr md ]
 pprPassDetails _ = empty
 \end{code}
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index ee20a52034..b8c8160972 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1416,7 +1416,7 @@ completeCall env var cont
       	  pprDefiniteTrace "Inlining done:" (ppr var) stuff
         else stuff
       | otherwise
-      = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var))
+      = pprDefiniteTrace ("Inlining done: " ++ showSDocDump (ppr var))
            (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
                   text "Cont:  " <+> ppr cont])
            stuff
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index 14235f4651..321deb866a 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -1137,7 +1137,7 @@ specCalls subst rules_for_me calls_for_me fn rhs
 	   ; let
 		-- The rule to put in the function's specialisation is:
 		--	forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b  
-	        rule_name = mkFastString ("SPEC " ++ showSDoc (ppr fn <+> ppr spec_ty_args))
+	        rule_name = mkFastString ("SPEC " ++ showSDocDump (ppr fn <+> ppr spec_ty_args))
   		spec_env_rule = mkRule True {- Auto generated -} is_local
                                   rule_name
 				  inl_act 	-- Note [Auto-specialisation and RULES]
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 54642e575f..91ce4887a4 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -30,7 +30,7 @@ module TcHsType (
         tcHsContext, tcInferApps, tcHsArgTys,
 
         ExpKind(..), ekConstraint, expArgKind, checkExpectedKind,
-        kindGeneralizeKind, kindGeneralizeKinds,
+        kindGeneralize,
 
 		-- Sort-checking kinds
 	tcLHsKind, 
@@ -823,53 +823,26 @@ tcHsTyVarBndr (L _ hs_tv)
 
 ------------------
 tcHsTyVarBndrsGen :: [LHsTyVarBndr Name] 
-	          -> TcM r 
-	          -> TcM ([TyVar], r)
+	          -> TcM (TcTyVarSet, r)  -- Result + free tyvars of thing inside
+	          -> TcM ([TyVar], r)     -- Generalised kind variables 
+                                          -- + zonked tyvars + result result
 -- tcHsTyVarBndrsGen [(f :: ?k -> *), (a :: ?k)] thing_inside
 -- Returns with tyvars [(k :: BOX), (f :: k -> *), (a :: k)]
 tcHsTyVarBndrsGen hs_tvs thing_inside
   = do { traceTc "tcHsTyVarBndrsGen" (ppr hs_tvs) 
-       ; (tvs, res) <- tcHsTyVarBndrs hs_tvs $ \ tvs ->
+       ; (tvs, (ftvs, res)) <- tcHsTyVarBndrs hs_tvs $ \ tvs ->
                        do { res <- thing_inside
                           ; return (tvs, res) }
        ; let kinds = map tyVarKind tvs
-       ; (kvs', zonked_kinds) <- kindGeneralizeKinds kinds
+       ; kvs' <- kindGeneralize (tyVarsOfTypes kinds `unionVarSet` 
+                                        (ftvs `delVarSetList` tvs))
+       ; zonked_kinds <- mapM zonkTcKind kinds
        ; let tvs' = zipWith setTyVarKind tvs zonked_kinds
                      -- See Note [Kinds of quantified type variables]
        ; traceTc "tcTyVarBndrsGen" (ppr (hs_tvs, kvs', tvs))
        ; return (kvs' ++ tvs', res) }
 
-------------------
--- Used when generalizing binders and type family patterns
--- It takes a kind from the type checker (like `k0 -> *`), and returns the 
--- final, kind-generalized kind (`forall k::BOX. k -> *`)
-kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
--- INVARIANT: the returned kinds are zonked, and
---            mention the returned kind variables
-kindGeneralizeKinds kinds 
-  = do { -- Quantify over kind variables free in
-         -- the kinds, and *not* in the environment
-       ; traceTc "kindGeneralizeKinds 1" (ppr kinds)
-
-       ; kvs <- kindGeneralize (tyVarsOfTypes kinds)
-
-         -- Zonk the kinds again, to pick up either the kind 
-         -- variables we quantify over, or *, depending on whether
-         -- zonkQuantifiedTyVars decided to generalise (which in
-         -- turn depends on PolyKinds)
-       ; final_kinds <- mapM zonkTcKind kinds
-
-       ; traceTc "kindGeneralizeKinds 2" (vcat [ ppr kinds, ppr kvs, ppr final_kinds ])
-       ; return (kvs, final_kinds) }
-
-
-kindGeneralizeKind :: TcKind -> TcM ([KindVar], Kind)    
--- Unary version of kindGeneralizeKinds
-kindGeneralizeKind kind
-  = do { kvs   <- kindGeneralize (tyVarsOfType kind)
-       ; kind' <- zonkTcKind kind
-       ; return (kvs, kind') }
-
+-------------------
 kindGeneralize :: TyVarSet -> TcM [KindVar]
 kindGeneralize tkvs
   = do { gbl_tvs  <- tcGetGlobalTyVars -- Already zonked
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 7ad12efc67..46a6abd540 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -251,12 +251,14 @@ newNoSigLetBndr (LetGblBndr prags) name ty
 ----------
 addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
 addInlinePrags poly_id prags
-  = tc_inl inl_sigs
+  = do { traceTc "addInlinePrags" (ppr poly_id $$ ppr prags) 
+       ; tc_inl inl_sigs }
   where
     inl_sigs = filter isInlineLSig prags
     tc_inl [] = return poly_id
     tc_inl (L loc (InlineSig _ prag) : other_inls)
        = do { unless (null other_inls) (setSrcSpan loc warn_dup_inline)
+            ; traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) 
             ; return (poly_id `setInlinePragma` prag) }
     tc_inl _ = panic "tc_inl"
 
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index b04f4156aa..c166e6210e 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -294,7 +294,8 @@ kcTyClGroup decls
            ; let kc_kind = case thing of
                                AThing k -> k
                                _ -> pprPanic "kcTyClGroup" (ppr thing)
-           ; (kvs, kc_kind') <- kindGeneralizeKind kc_kind
+           ; kvs <- kindGeneralize (tyVarsOfType kc_kind)
+           ; kc_kind' <- zonkTcKind kc_kind
            ; return (name, mkForAllTys kvs kc_kind') }
 
 getInitialKinds :: LTyClDecl Name -> TcM [(Name, TcTyThing)]
@@ -433,6 +434,8 @@ kcFamilyDecl d = pprPanic "kcFamilyDecl" (ppr d)
 kcResultKind :: Maybe (LHsKind Name) -> Kind -> TcM ()
 kcResultKind Nothing res_k
   = discardResult (unifyKind res_k liftedTypeKind)
+      --             type family F a 
+      -- defaults to type family F a :: *
 kcResultKind (Just k) res_k
   = do { k' <- tcLHsKind k
        ; discardResult (unifyKind k' res_k) }
@@ -749,24 +752,18 @@ tcFamTyPats fam_tc tyvars arg_pats kind_checker thing_inside
                  = splitKindFunTysN fam_arity $
                    substKiWith fam_kvs fam_arg_kinds fam_body
 
-         -- Kind-check
-       ; (tvs, typats) <- tcHsTyVarBndrs tyvars $ \tvs -> do
+         -- Kind-check and quantify
+         -- See Note [Quantifying over family patterns]
+       ; (tkvs, typats) <- tcHsTyVarBndrsGen tyvars $ do
                 { typats <- tcHsArgTys (quotes (ppr fam_tc)) arg_pats arg_kinds
                 ; kind_checker res_kind
-                ; return (tvs, typats) }
+                ; return (tyVarsOfTypes typats, typats) }
 
-         -- Quantify
-         -- See Note [Quantifying over family patterns]
-       ; let tv_kinds = map tyVarKind tvs
-       ; (kvs, kinds') <- kindGeneralizeKinds (tv_kinds ++ fam_arg_kinds)
-       ; typats'   <- zonkTcTypeToTypes emptyZonkEnv typats
+       ; all_args' <- zonkTcTypeToTypes emptyZonkEnv (fam_arg_kinds ++ typats)
        ; res_kind' <- zonkTcTypeToType emptyZonkEnv res_kind
-       ; let (tv_kinds', fam_arg_kinds') = splitAtList tv_kinds kinds'
-             tvs' = zipWith setTyVarKind tvs tv_kinds'
-             tkvs = kvs ++ tvs'   -- Kind and type variables
-       ; traceTc "tcFamPats" (ppr tvs' $$ ppr kvs $$ ppr kinds')
+       ; traceTc "tcFamPats" (ppr tkvs $$ ppr all_args' $$ ppr res_kind')
        ; tcExtendTyVarEnv tkvs $
-         thing_inside tkvs (fam_arg_kinds' ++ typats') res_kind' }
+         thing_inside tkvs all_args' res_kind' }
 \end{code}
 
 Note [Quantifying over family patterns]
@@ -876,21 +873,25 @@ tcConDecl new_or_data existential_ok rep_tycon res_tmpl 	-- Data types
                        , con_details = details, con_res = res_ty })
   = addErrCtxt (dataConCtxt name) $
     do { traceTc "tcConDecl 1" (ppr name)
-       ; (tvs', stuff) <- tcHsTyVarBndrsGen tvs $ 
+       ; (tvs', (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) 
+           <- tcHsTyVarBndrsGen tvs $ 
               do { ctxt'    <- tcHsContext ctxt
                  ; details' <- tcConArgs new_or_data details
                  ; res_ty'  <- tcConRes res_ty
-                 ; return (ctxt', details', res_ty') }
+                 ; let (is_infix, field_lbls, btys') = details'
+                       (arg_tys', stricts)           = unzip btys'
+                       ftvs = tyVarsOfTypes ctxt'     `unionVarSet`
+                              tyVarsOfTypes arg_tys'  `unionVarSet`
+                              case res_ty' of
+                                 ResTyH98     -> emptyVarSet
+                                 ResTyGADT ty -> tyVarsOfType ty
+                 ; return (ftvs, (ctxt', arg_tys', res_ty', is_infix, field_lbls, stricts)) }
 
-       ; let (ctxt', details', res_ty')    = stuff
-             (is_infix, field_lbls, btys') = details'
-             (arg_tys', stricts)           = unzip btys'
 
              -- Substitute, to account for the kind 
              -- unifications done by tcHsTyVarBndrsGen
-             ze = mkTyVarZonkEnv tvs'
-       
        ; traceTc "tcConDecl 2" (ppr name)
+       ; let ze = mkTyVarZonkEnv tvs'
        ; arg_tys' <- zonkTcTypeToTypes ze arg_tys'
        ; ctxt'    <- zonkTcTypeToTypes ze ctxt'
        ; res_ty'  <- case res_ty' of
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index b71389663e..b96ae5e063 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -388,29 +388,29 @@ renderWithStyle sdoc sty =
 -- showSDoc, designed for when we're getting results like "Foo.bar"
 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
 showSDocOneLine :: SDoc -> String
-showSDocOneLine d =
-  Pretty.showDocWith PageMode
+showSDocOneLine d 
+ = Pretty.showDocWith PageMode
     (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocForUser :: PrintUnqualified -> SDoc -> String
-showSDocForUser unqual doc =
-  show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
+showSDocForUser unqual doc
+ = show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
 
 showSDocUnqual :: SDoc -> String
 -- Only used in the gruesome isOperator
-showSDocUnqual d =
-  show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
+showSDocUnqual d 
+ = show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
 
 showsPrecSDoc :: Int -> SDoc -> ShowS
 showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
 
 showSDocDump :: SDoc -> String
-showSDocDump d =
-  Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
+showSDocDump d 
+ = Pretty.showDocWith PageMode (runSDoc d (initSDocContext defaultDumpStyle))
 
 showSDocDumpOneLine :: SDoc -> String
-showSDocDumpOneLine d =
-  Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
+showSDocDumpOneLine d
+ = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
 
 showSDocDebug :: SDoc -> String
 showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
@@ -923,27 +923,27 @@ plural _   = char 's'
 
 pprPanic :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in GHC"
-pprPanic    = pprAndThen panic
+pprPanic    = pprDebugAndThen panic
 
 pprSorry :: String -> SDoc -> a
 -- ^ Throw an exception saying "this isn't finished yet"
-pprSorry    = pprAndThen sorry
+pprSorry    = pprDebugAndThen sorry
 
 
 pprPgmError :: String -> SDoc -> a
 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
-pprPgmError = pprAndThen pgmError
+pprPgmError = pprDebugAndThen pgmError
 
 
 pprTrace :: String -> SDoc -> a -> a
 -- ^ If debug output is on, show some 'SDoc' on the screen
 pprTrace str doc x
    | opt_NoDebugOutput = x
-   | otherwise         = pprAndThen trace str doc x
+   | otherwise         = pprDebugAndThen trace str doc x
 
 pprDefiniteTrace :: String -> SDoc -> a -> a
 -- ^ Same as pprTrace, but show even if -dno-debug-output is on
-pprDefiniteTrace str doc x = pprAndThen trace str doc x
+pprDefiniteTrace str doc x = pprDebugAndThen trace str doc x
 
 pprPanicFastInt :: String -> SDoc -> FastInt
 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
@@ -952,33 +952,31 @@ pprPanicFastInt heading pretty_msg =
   where
     doc = text heading <+> pretty_msg
 
-
-pprAndThen :: (String -> a) -> String -> SDoc -> a
-pprAndThen cont heading pretty_msg =
-  cont (show (runSDoc doc (initSDocContext PprDebug)))
- where
-     doc = sep [text heading, nest 4 pretty_msg]
-
-assertPprPanic :: String -> Int -> SDoc -> a
--- ^ Panic with an assertation failure, recording the given file and line number.
--- Should typically be accessed with the ASSERT family of macros
-assertPprPanic file line msg
-  = panic (show (runSDoc doc (initSDocContext PprDebug)))
-  where
-    doc = sep [hsep[text "ASSERT failed! file",
-                           text file,
-                           text "line", int line],
-                    msg]
-
 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 -- ^ Just warn about an assertion failure, recording the given file and line number.
 -- Should typically be accessed with the WARN macros
 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 warnPprTrace False _file _line _msg x = x
 warnPprTrace True   file  line  msg x
-  = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
+  = pprDebugAndThen trace "WARNING:" doc x
   where
     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
                msg]
+
+assertPprPanic :: String -> Int -> SDoc -> a
+-- ^ Panic with an assertation failure, recording the given file and line number.
+-- Should typically be accessed with the ASSERT family of macros
+assertPprPanic file line msg
+  = pprDebugAndThen panic "ASSERT failed!" doc
+  where
+    doc = sep [ hsep [ text "file", text file
+                     , text "line", int line ]
+              , msg ]
+
+pprDebugAndThen :: (String -> a) -> String -> SDoc -> a
+pprDebugAndThen cont heading pretty_msg 
+ = cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+     doc = sep [text heading, nest 4 pretty_msg]
 \end{code}
 
diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs
index 66f51e64e6..47dd7798cd 100644
--- a/compiler/utils/Platform.hs
+++ b/compiler/utils/Platform.hs
@@ -58,6 +58,7 @@ data OS
         | OSOpenBSD
         | OSNetBSD
         | OSKFreeBSD
+        | OSHaiku
         deriving (Read, Show, Eq)
 
 -- | ARM Instruction Set Architecture and Extensions
@@ -91,6 +92,7 @@ osElfTarget OSSolaris2  = True
 osElfTarget OSDarwin    = False
 osElfTarget OSMinGW32   = False
 osElfTarget OSKFreeBSD  = True
+osElfTarget OSHaiku     = True
 osElfTarget OSUnknown   = False
  -- Defaulting to False is safe; it means don't rely on any
  -- ELF-specific functionality.  It is important to have a default for