compiler/deSugar/DsArrows.lhs

@@ -21,7 +21,7 @@ import Match
 import DsUtils
 import DsMonad
 
-import HsSyn	hiding (collectPatBinders, collectPatsBinders )
+import HsSyn	hiding (collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectLStmtBinders, collectStmtBinders )
 import TcHsSyn
 
 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
@@ -265,21 +265,21 @@ Translation of command judgements of the form
 	A | xs |- c :: [ts] t
 
 \begin{code}
-dsLCmd :: DsCmdEnv -> IdSet -> [Id] -> [Type] -> Type -> LHsCmd Id
+dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id]
        -> DsM (CoreExpr, IdSet)
-dsLCmd ids local_vars env_ids stack res_ty cmd
-  = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd)
+dsLCmd ids local_vars stack res_ty cmd env_ids
+  = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids
 
 dsCmd   :: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this command
-	-> [Id]			-- list of vars in the input to this command
-				-- This is typically fed back,
-				-- so don't pull on it too early
 	-> [Type]		-- type of the stack
 	-> Type			-- return type of the command
 	-> HsCmd Id		-- command to desugar
+	-> [Id]			-- list of vars in the input to this command
+				-- This is typically fed back,
+				-- so don't pull on it too early
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet)		-- set of local vars that occur free
+		IdSet)		-- subset of local vars that occur free
 
 --	A |- f :: a (t*ts) t'
 --	A, xs |- arg :: t
@@ -288,8 +288,9 @@ dsCmd   :: DsCmdEnv		-- arrow combinators
 --
 --		---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f
 
-dsCmd ids local_vars env_ids stack res_ty
-	(HsArrApp arrow arg arrow_ty HsFirstOrderApp _)= do
+dsCmd ids local_vars stack res_ty
+        (HsArrApp arrow arg arrow_ty HsFirstOrderApp _)
+        env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
@@ -304,7 +305,7 @@ dsCmd ids local_vars env_ids stack res_ty
               res_ty
               core_make_arg
               core_arrow,
-               exprFreeVars core_arg `intersectVarSet` local_vars)
+            exprFreeIds core_arg `intersectVarSet` local_vars)
 
 --	A, xs |- f :: a (t*ts) t'
 --	A, xs |- arg :: t
@@ -313,8 +314,9 @@ dsCmd ids local_vars env_ids stack res_ty
 --
 --		---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app
 
-dsCmd ids local_vars env_ids stack res_ty
-	(HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = do
+dsCmd ids local_vars stack res_ty
+        (HsArrApp arrow arg arrow_ty HsHigherOrderApp _)
+        env_ids = do
     let
         (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
@@ -332,7 +334,7 @@ dsCmd ids local_vars env_ids stack res_ty
               res_ty
               core_make_pair
               (do_app ids arg_ty res_ty),
-            (exprFreeVars core_arrow `unionVarSet` exprFreeVars core_arg)
+            (exprFreeIds core_arrow `unionVarSet` exprFreeIds core_arg)
               `intersectVarSet` local_vars)
 
 --	A | ys |- c :: [t:ts] t'
@@ -342,7 +344,7 @@ dsCmd ids local_vars env_ids stack res_ty
 --
 --		---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c
 
-dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
+dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do
     core_arg <- dsLExpr arg
     let
         arg_ty = exprType core_arg
@@ -363,8 +365,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
                       res_ty
                       core_map
                       core_cmd,
-      (exprFreeVars core_arg `intersectVarSet` local_vars)
-              `unionVarSet` free_vars)
+            free_vars `unionVarSet`
+              (exprFreeIds core_arg `intersectVarSet` local_vars))
 
 --	A | ys |- c :: [ts] t'
 --	-----------------------------------------------
@@ -372,11 +374,12 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) = do
 --
 --		---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c
 
-dsCmd ids local_vars env_ids stack res_ty
-    (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) = do
+dsCmd ids local_vars stack res_ty
+        (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _))
+        env_ids = do
     let
         pat_vars = mkVarSet (collectPatsBinders pats)
-        local_vars' = local_vars `unionVarSet` pat_vars
+        local_vars' = pat_vars `unionVarSet` local_vars
         stack' = drop (length pats) stack
     (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body
     stack_ids <- mapM newSysLocalDs stack
@@ -399,8 +402,8 @@ dsCmd ids local_vars env_ids stack res_ty
     return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body,
             free_vars `minusVarSet` pat_vars)
 
-dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
-  = dsLCmd ids local_vars env_ids stack res_ty cmd
+dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids
+  = dsLCmd ids local_vars stack res_ty cmd env_ids
 
 --	A, xs |- e :: Bool
 --	A | xs1 |- c1 :: [ts] t
@@ -412,7 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd)
 --			if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>>
 --		     c1 ||| c2
 
-dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) = do
+dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd)
+        env_ids = do
     core_cond <- dsLExpr cond
     (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd
     (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd
@@ -428,7 +432,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsIf mb_fun cond then_cmd else_cmd) =
         then_ty = envStackType then_ids stack
         else_ty = envStackType else_ids stack
         sum_ty = mkTyConApp either_con [then_ty, else_ty]
-        fvs_cond = exprFreeVars core_cond `intersectVarSet` local_vars
+        fvs_cond = exprFreeIds core_cond `intersectVarSet` local_vars
         
         core_left  = mk_left_expr  then_ty else_ty (buildEnvStack then_ids stack_ids)
         core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids)
@@ -472,7 +476,8 @@ case bodies, containing the following fields:
    bodies with |||.
 
 \begin{code}
-dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_ty)) = do
+dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty))
+        env_ids = do
     stack_ids <- mapM newSysLocalDs stack
 
     -- Extract and desugar the leaf commands in the case, building tuple
@@ -482,7 +487,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
         leaves = concatMap leavesMatch matches
         make_branch (leaf, bound_vars) = do
             (core_leaf, _fvs, leaf_ids) <-
-                  dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf
+                  dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack res_ty leaf
             return ([mkHsEnvStackExpr leaf_ids stack_ids],
                     envStackType leaf_ids stack,
                     core_leaf)
@@ -522,7 +527,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
     core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty'))
     core_matches <- matchEnvStack env_ids stack_ids core_body
     return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices,
-            exprFreeVars core_body `intersectVarSet` local_vars)
+            exprFreeIds core_body  `intersectVarSet` local_vars)
 
 --	A | ys |- c :: [ts] t
 --	----------------------------------
@@ -530,10 +535,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
 --
 --		---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c
 
-dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
+dsCmd ids local_vars stack res_ty (HsLet binds body) env_ids = do
     let
         defined_vars = mkVarSet (collectLocalBinders binds)
-        local_vars' = local_vars `unionVarSet` defined_vars
+        local_vars' = defined_vars `unionVarSet` local_vars
     
     (core_body, _free_vars, env_ids') <- dsfixCmd ids local_vars' stack res_ty body
     stack_ids <- mapM newSysLocalDs stack
@@ -547,26 +552,25 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = do
                         res_ty
                         core_map
                         core_body,
-        exprFreeVars core_binds `intersectVarSet` local_vars)
+        exprFreeIds core_binds `intersectVarSet` local_vars)
 
-dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _)
-  = dsCmdDo ids local_vars env_ids res_ty stmts 
+dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids
+  = dsCmdDo ids local_vars res_ty stmts env_ids
 
 --	A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t
 --	A | xs |- ci :: [tsi] ti
 --	-----------------------------------
 --	A | xs |- (|e c1 ... cn|) :: [ts] t	---> e [t_xs] c1 ... cn
 
-dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = do
+dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do
     let env_ty = mkBigCoreVarTupTy env_ids
     core_op <- dsLExpr op
     (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionVarSets fv_sets)
 
-
-dsCmd ids local_vars env_ids stack res_ty (HsTick tickish expr) = do
-    (expr1,id_set) <- dsLCmd ids local_vars env_ids stack res_ty expr
+dsCmd ids local_vars stack res_ty (HsTick tickish expr) env_ids = do
+    (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids
     return (Tick tickish expr1, id_set)
 
 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
@@ -578,9 +582,9 @@ dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
 dsTrimCmdArg
 	:: IdSet		-- set of local vars available to this command
 	-> [Id]			-- list of vars in the input to this command
-	-> LHsCmdTop Id	-- command argument to desugar
+	-> LHsCmdTop Id		-- command argument to desugar
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet)		-- set of local vars that occur free
+		IdSet)		-- subset of local vars that occur free
 dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = do
     meth_ids <- mkCmdEnv ids
     (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd
@@ -603,11 +607,24 @@ dsfixCmd
 	-> Type			-- return type of the command
 	-> LHsCmd Id		-- command to desugar
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet,		-- set of local vars that occur free
-		[Id])		-- set as a list, fed back
+		IdSet,		-- subset of local vars that occur free
+		[Id])		-- the same local vars as a list, fed back
 dsfixCmd ids local_vars stack cmd_ty cmd
-  = fixDs (\ ~(_,_,env_ids') -> do
-        (core_cmd, free_vars) <- dsLCmd ids local_vars env_ids' stack cmd_ty cmd
+  = trimInput (dsLCmd ids local_vars stack cmd_ty cmd)
+
+-- Feed back the list of local variables actually used a command,
+-- for use as the input tuple of the generated arrow.
+
+trimInput
+	:: ([Id] -> DsM (CoreExpr, IdSet))
+	-> DsM (CoreExpr,	-- desugared expression
+		IdSet,		-- subset of local vars that occur free
+		[Id])		-- same local vars as a list, fed back to
+				-- the inner function to form the tuple of
+				-- inputs to the arrow.
+trimInput build_arrow
+  = fixDs (\ ~(_,_,env_ids) -> do
+        (core_cmd, free_vars) <- build_arrow env_ids
         return (core_cmd, free_vars, varSetElems free_vars))
 
 \end{code}
@@ -620,31 +637,29 @@ Translation of command judgements of the form
 
 dsCmdDo :: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
+	-> Type			-- return type of the statement
+	-> [LStmt Id]		-- statements to desugar
 	-> [Id]			-- list of vars in the input to this statement
 				-- This is typically fed back,
 				-- so don't pull on it too early
-	-> Type			-- return type of the statement
-	-> [LStmt Id]		-- statements to desugar
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet)		-- set of local vars that occur free
+		IdSet)		-- subset of local vars that occur free
 
 --	A | xs |- c :: [] t
 --	--------------------------
 --	A | xs |- do { c } :: [] t
 
-dsCmdDo _ _ _ _ [] = panic "dsCmdDo"
+dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
 
-dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)]
-  = dsLCmd ids local_vars env_ids [] res_ty body
+dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids
+  = dsLCmd ids local_vars [] res_ty body env_ids
 
-dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do
+dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
     let
         bound_vars = mkVarSet (collectLStmtBinders stmt)
-        local_vars' = local_vars `unionVarSet` bound_vars
-    (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do
-        (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts 
-        return (core_stmts, fv_stmts, varSetElems fv_stmts))
-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
+        local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
     return (do_compose ids
                 (mkBigCoreVarTupTy env_ids)
                 (mkBigCoreVarTupTy env_ids')
@@ -658,21 +673,21 @@ A statement maps one local environment to another, and is represented
 as an arrow from one tuple type to another.  A statement sequence is
 translated to a composition of such arrows.
 \begin{code}
-dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> [Id] -> LStmt Id
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt Id -> [Id]
            -> DsM (CoreExpr, IdSet)
-dsCmdLStmt ids local_vars env_ids out_ids cmd
-  = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd)
+dsCmdLStmt ids local_vars out_ids cmd env_ids
+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
 
 dsCmdStmt
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
+	-> [Id]			-- list of vars in the output of this statement
+	-> Stmt Id		-- statement to desugar
 	-> [Id]			-- list of vars in the input to this statement
 				-- This is typically fed back,
 				-- so don't pull on it too early
-	-> [Id]			-- list of vars in the output of this statement
-	-> Stmt Id	-- statement to desugar
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet)		-- set of local vars that occur free
+		IdSet)		-- subset of local vars that occur free
 
 --	A | xs1 |- c :: [] t
 --	A | xs' |- do { ss } :: [] t'
@@ -682,7 +697,7 @@ dsCmdStmt
 --		---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>>
 --			arr snd >>> ss
 
-dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
+dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd
     core_mux <- matchEnvStack env_ids []
         (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids))
@@ -711,7 +726,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
 
-dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do
+dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] (hsLPatType pat) cmd
     let
 	pat_ty = hsLPatType pat
@@ -760,7 +775,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _) = do
 --
 --		---> arr (\ (xs) -> let binds in (xs')) >>> ss
 
-dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
+dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
     -- build a new environment using the let bindings
     core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
     -- match the old environment against the input
@@ -769,7 +784,7 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
 			(mkBigCoreVarTupTy env_ids)
 			(mkBigCoreVarTupTy out_ids)
 			core_map,
-	exprFreeVars core_binds `intersectVarSet` local_vars)
+	    exprFreeIds core_binds `intersectVarSet` local_vars)
 
 --	A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ...
 --	A | xs' |- do { ss' } :: [] t
@@ -785,9 +800,11 @@ dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds) = do
 --			first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
 --			arr (\((xs1),(xs2)) -> (xs')) >>> ss'
 
-dsCmdStmt ids local_vars env_ids out_ids 
-          (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids
-                   , recS_rec_rets = rhss }) = do
+dsCmdStmt ids local_vars out_ids
+        (RecStmt { recS_stmts = stmts
+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
+                 , recS_later_rets = later_rets, recS_rec_rets = rec_rets })
+        env_ids = do
     let
         env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids
         env2_ids = varSetElems env2_id_set
@@ -807,7 +824,7 @@ dsCmdStmt ids local_vars env_ids out_ids
     --- loop (...)
 
     (core_loop, env1_id_set, env1_ids)
-               <- dsRecCmd ids local_vars stmts later_ids rec_ids rhss
+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
 
     -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
 
@@ -838,25 +855,41 @@ dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
 
 --	loop (arr (\ ((env1_ids), ~(rec_ids)) -> (env_ids)) >>>
 --	      ss >>>
---	      arr (\ (out_ids) -> ((later_ids),(rhss))) >>>
-
-dsRecCmd :: DsCmdEnv -> VarSet -> [LStmt Id] -> [Var] -> [Var] -> [HsExpr Id]
-         -> DsM (CoreExpr, VarSet, [Var])
-dsRecCmd ids local_vars stmts later_ids rec_ids rhss = do
+--	      arr (\ (out_ids) -> ((later_rets),(rec_rets))) >>>
+
+dsRecCmd
+        :: DsCmdEnv		-- arrow combinators
+        -> IdSet		-- set of local vars available to this statement
+        -> [LStmt Id]		-- list of statements inside the RecCmd
+        -> [Id]			-- list of vars defined here and used later
+        -> [HsExpr Id]		-- expressions corresponding to later_ids
+        -> [Id]			-- list of vars fed back through the loop
+        -> [HsExpr Id]		-- expressions corresponding to rec_ids
+        -> DsM (CoreExpr,	-- desugared statement
+                IdSet,		-- subset of local vars that occur free
+                [Id])		-- same local vars as a list
+
+dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
     let
+        later_id_set = mkVarSet later_ids
         rec_id_set = mkVarSet rec_ids
-        out_ids = varSetElems (mkVarSet later_ids `unionVarSet` rec_id_set)
-        out_ty = mkBigCoreVarTupTy out_ids
-        local_vars' = local_vars `unionVarSet` rec_id_set
+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
 
-    -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss))
+    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
 
-    core_rhss <- mapM dsExpr rhss
+    core_later_rets <- mapM dsExpr later_rets
+    core_rec_rets <- mapM dsExpr rec_rets
     let
-        later_tuple = mkBigCoreVarTup later_ids
+        -- possibly polymorphic version of vars of later_ids and rec_ids
+        out_ids = varSetElems (unionVarSets (map exprFreeIds (core_later_rets ++ core_rec_rets)))
+        out_ty = mkBigCoreVarTupTy out_ids
+
+        later_tuple = mkBigCoreTup core_later_rets
         later_ty = mkBigCoreVarTupTy later_ids
-        rec_tuple = mkBigCoreTup core_rhss
+
+        rec_tuple = mkBigCoreTup core_rec_rets
         rec_ty = mkBigCoreVarTupTy rec_ids
+
         out_pair = mkCorePairExpr later_tuple rec_tuple
         out_pair_ty = mkCorePairTy later_ty rec_ty
 
@@ -905,34 +938,32 @@ dsfixCmdStmts
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
 	-> [Id]			-- output vars of these statements
-	-> [LStmt Id]	-- statements to desugar
+	-> [LStmt Id]		-- statements to desugar
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet,		-- set of local vars that occur free
-		[Id])		-- input vars
+		IdSet,		-- subset of local vars that occur free
+		[Id])		-- same local vars as a list
 
 dsfixCmdStmts ids local_vars out_ids stmts
-  = fixDs (\ ~(_,_,env_ids) -> do
-        (core_stmts, fv_stmts) <- dsCmdStmts ids local_vars env_ids out_ids stmts
-	return (core_stmts, fv_stmts, varSetElems fv_stmts))
+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)
 
 dsCmdStmts
 	:: DsCmdEnv		-- arrow combinators
 	-> IdSet		-- set of local vars available to this statement
-	-> [Id]			-- list of vars in the input to these statements
 	-> [Id]			-- output vars of these statements
-	-> [LStmt Id]	-- statements to desugar
+	-> [LStmt Id]		-- statements to desugar
+	-> [Id]			-- list of vars in the input to these statements
 	-> DsM (CoreExpr,	-- desugared expression
-		IdSet)		-- set of local vars that occur free
+		IdSet)		-- subset of local vars that occur free
 
-dsCmdStmts ids local_vars env_ids out_ids [stmt]
-  = dsCmdLStmt ids local_vars env_ids out_ids stmt
+dsCmdStmts ids local_vars out_ids [stmt] env_ids
+  = dsCmdLStmt ids local_vars out_ids stmt env_ids
 
-dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
+dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
     let
         bound_vars = mkVarSet (collectLStmtBinders stmt)
-        local_vars' = local_vars `unionVarSet` bound_vars
+        local_vars' = bound_vars `unionVarSet` local_vars
     (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
     return (do_compose ids
                 (mkBigCoreVarTupTy env_ids)
                 (mkBigCoreVarTupTy env_ids')
@@ -941,7 +972,7 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = do
                 core_stmts,
               fv_stmt)
 
-dsCmdStmts _ _ _ _ [] = panic "dsCmdStmts []"
+dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
 
 \end{code}
 
@@ -1081,4 +1112,21 @@ add_ev_bndr :: EvBind -> [Id] -> [Id]
 add_ev_bndr (EvBind b _) bs | isId b    = b:bs
                             | otherwise = bs
   -- A worry: what about coercion variable binders??
+
+collectLStmtsBinders :: [LStmt Id] -> [Id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+
+collectLStmtBinders :: LStmt Id -> [Id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt Id -> [Id]
+collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
+collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
+collectStmtBinders (ExprStmt {})        = []
+collectStmtBinders (LastStmt {})        = []
+collectStmtBinders (ParStmt xs _ _ _)   = collectLStmtsBinders
+                                        $ concatMap fst xs
+collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
+
 \end{code}

compiler/deSugar/DsExpr.lhs

@@ -758,21 +758,21 @@ dsDo stmts
       = ASSERT( length rec_ids > 0 )
         goL (new_bind_stmt : stmts)
       where
-        new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats)
+        new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTup later_pats)
                                          mfix_app bind_op 
                                          noSyntaxExpr  -- Tuple cannot fail
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
-        tup_ty       = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case
+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
         mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
         mfix_arg     = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
                                                  (mkFunTy tup_ty body_ty))
-        mfix_pat     = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats
+        mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
         body         = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
-        ret_app      = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets)
+        ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
         ret_stmt     = noLoc $ mkLastStmt ret_app
                      -- This LastStmt will be desugared with dsDo, 
                      -- which ignores the return_op in the LastStmt,

compiler/deSugar/DsForeign.lhs

@@ -138,7 +138,7 @@ dsCImport :: Id
           -> DsM ([Binding], SDoc, SDoc)
 dsCImport id co (CLabel cid) cconv _ _ = do
    let ty = pFst $ coercionKind co
-       fod = case tyConAppTyCon_maybe ty of
+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
              Just tycon
               | tyConUnique tycon == funPtrTyConKey ->
                  IsFunction

compiler/ghc.cabal.in

@@ -65,11 +65,11 @@ Library
         Build-Depends: directory  >= 1   && < 1.2,
                        process    >= 1   && < 1.2,
                        bytestring >= 0.9 && < 0.10,
-                       old-time   >= 1   && < 1.1,
+                       old-time   >= 1   && < 1.2,
                        containers >= 0.1 && < 0.5,
-                       array      >= 0.1 && < 0.4
+                       array      >= 0.1 && < 0.5
 
-    Build-Depends: filepath >= 1 && < 1.3
+    Build-Depends: filepath >= 1 && < 1.4
     Build-Depends: Cabal, hpc
     if os(windows)
         Build-Depends: Win32

compiler/ghc.mk

@@ -497,7 +497,7 @@ compiler/hsSyn/HsLit_HC_OPTS     += -fomit-interface-pragmas
 endif
 
 # LibFFI.hs #includes ffi.h
-compiler/stage2/build/LibFFI.hs : $(ffi_HEADER)
+compiler/stage2/build/LibFFI.hs : $(libffi_HEADERS)
 # On Windows it seems we also need to link directly to libffi
 ifeq  "$(HOSTPLATFORM)" "i386-unknown-mingw32"
 define windowsDynLinkToFfi

compiler/ghci/ObjLink.lhs

@@ -36,12 +36,7 @@ import Control.Monad    ( when )
 import Foreign.C
 import Foreign		( nullPtr )
 import GHC.Exts         ( Ptr(..) )
-#if __GLASGOW_HASKELL__ >= 703
-import GHC.IO.Encoding (getFileSystemEncoding)
-#else
-import GHC.IO.Encoding (TextEncoding, fileSystemEncoding)
-#endif
-import qualified GHC.Foreign as GHC
+import System.Posix.Internals ( CFilePath, withFilePath )
 import System.FilePath  ( dropExtension )
 
 
@@ -49,21 +44,10 @@ import System.FilePath  ( dropExtension )
 -- RTS Linker Interface
 -- ---------------------------------------------------------------------------
 
-#if __GLASGOW_HASKELL__ < 703
-getFileSystemEncoding :: IO TextEncoding
-getFileSystemEncoding = return fileSystemEncoding
-#endif
-
--- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page
-withFileCString :: FilePath -> (CString -> IO a) -> IO a
-withFileCString fp f = do
-    enc <- getFileSystemEncoding
-    GHC.withCString enc fp f
-
 insertSymbol :: String -> String -> Ptr a -> IO ()
 insertSymbol obj_name key symbol
     = let str = prefixUnderscore key
-      in withFileCString obj_name $ \c_obj_name ->
+      in withFilePath obj_name $ \c_obj_name ->
          withCAString str $ \c_str ->
           c_insertSymbol c_obj_name c_str symbol
 
@@ -99,7 +83,7 @@ loadDLL str0 = do
      str | isWindowsHost = dropExtension str0
          | otherwise     = str0
   --
-  maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll
+  maybe_errmsg <- withFilePath str $ \dll -> c_addDLL dll
   if maybe_errmsg == nullPtr
 	then return Nothing
 	else do str <- peekCString maybe_errmsg
@@ -107,19 +91,19 @@ loadDLL str0 = do
 
 loadArchive :: String -> IO ()
 loadArchive str = do
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_loadArchive c_str
      when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed"))
 
 loadObj :: String -> IO ()
 loadObj str = do
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_loadObj c_str
      when (r == 0) (panic ("loadObj " ++ show str ++ ": failed"))
 
 unloadObj :: String -> IO ()
 unloadObj str =
-   withFileCString str $ \c_str -> do
+   withFilePath str $ \c_str -> do
      r <- c_unloadObj c_str
      when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed"))
 
@@ -132,12 +116,12 @@ resolveObjs = do
 -- Foreign declarations to RTS entry points which does the real work;
 -- ---------------------------------------------------------------------------
 
-foreign import ccall unsafe "addDLL"	   c_addDLL :: CString -> IO CString
+foreign import ccall unsafe "addDLL"       c_addDLL :: CFilePath -> IO CString
 foreign import ccall unsafe "initLinker"   initObjLinker :: IO ()
-foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CString -> CString -> Ptr a -> IO ()
+foreign import ccall unsafe "insertSymbol" c_insertSymbol :: CFilePath -> CString -> Ptr a -> IO ()
 foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a)
-foreign import ccall unsafe "loadArchive"  c_loadArchive :: CString -> IO Int
-foreign import ccall unsafe "loadObj"      c_loadObj :: CString -> IO Int
-foreign import ccall unsafe "unloadObj"    c_unloadObj :: CString -> IO Int
+foreign import ccall unsafe "loadArchive"  c_loadArchive :: CFilePath -> IO Int
+foreign import ccall unsafe "loadObj"      c_loadObj :: CFilePath -> IO Int
+foreign import ccall unsafe "unloadObj"    c_unloadObj :: CFilePath -> IO Int
 foreign import ccall unsafe "resolveObjs"  c_resolveObjs :: IO Int
 \end{code}

compiler/ghci/RtClosureInspect.hs

@@ -72,7 +72,7 @@ import Data.Array.Base
 import Data.Ix
 import Data.List
 import qualified Data.Sequence as Seq
-import Data.Monoid
+import Data.Monoid (mappend)
 import Data.Sequence (viewl, ViewL(..))
 import Foreign.Safe
 import System.IO.Unsafe

compiler/hsSyn/HsDecls.lhs

@@ -802,8 +802,8 @@ pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs
                     , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprHsInfix con, ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprHsVar con : map ppr tys)
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc (unLoc con), ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc (unLoc con) : map ppr tys)
     ppr_details (RecCon fields)  = ppr con <+> pprConDeclFields fields
 
 pprConDecl (ConDecl { con_name = con, con_explicit = expl, con_qvars = tvs

compiler/hsSyn/HsExpr.lhs

@@ -379,7 +379,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
 ppr_lexpr e = ppr_expr (unLoc e)
 
 ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
-ppr_expr (HsVar v)       = pprHsVar v
+ppr_expr (HsVar v)       = pprPrefixOcc v
 ppr_expr (HsIPVar v)     = ppr v
 ppr_expr (HsLit lit)     = ppr lit
 ppr_expr (HsOverLit lit) = ppr lit
@@ -407,7 +407,7 @@ ppr_expr (OpApp e1 op _ e2)
       = hang (ppr op) 2 (sep [pp_e1, pp_e2])
 
     pp_infixly v
-      = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]]
+      = sep [pp_e1, sep [pprInfixOcc v, nest 2 pp_e2]]
 
 ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
 
@@ -420,7 +420,7 @@ ppr_expr (SectionL expr op)
 
     pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
                        4 (hsep [pp_expr, ptext (sLit "x_ )")])
-    pp_infixly v = (sep [pp_expr, pprHsInfix v])
+    pp_infixly v = (sep [pp_expr, pprInfixOcc v])
 
 ppr_expr (SectionR op expr)
   = case unLoc op of
@@ -431,7 +431,7 @@ ppr_expr (SectionR op expr)
 
     pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
                        4 ((<>) pp_expr rparen)
-    pp_infixly v = sep [pprHsInfix v, pp_expr]
+    pp_infixly v = sep [pprInfixOcc v, pp_expr]
 
 ppr_expr (ExplicitTuple exprs boxity)
   = tupleParens (boxityNormalTupleSort boxity) (fcat (ppr_tup_args exprs))
@@ -541,7 +541,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
   = hsep [ppr_lexpr arg, ptext (sLit ">>-"), ppr_lexpr arrow]
 
 ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
-  = sep [pprCmdArg (unLoc arg1), hsep [pprHsInfix v, pprCmdArg (unLoc arg2)]]
+  = sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <> ptext (sLit "|)"))
@@ -928,10 +928,11 @@ data StmtLR idL idR
      , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
 
         -- These fields are only valid after typechecking
-     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 with
-                                     -- recS_rec_ids, and are the
-                                     -- expressions that should be returned by
-                                     -- the recursion.
+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1
+                                     -- with recS_later_ids and recS_rec_ids,
+                                     -- and are the expressions that should be
+                                     -- returned by the recursion.
                                      -- They may not quite be the Ids themselves,
                                      -- because the Id may be *polymorphic*, but
                                      -- the returned thing has to be *monomorphic*, 

compiler/hsSyn/HsImpExp.lhs

@@ -57,7 +57,7 @@ simpleImportDecl mn = ImportDecl {
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (ImportDecl name) where
+instance (OutputableBndr name) => Outputable (ImportDecl name) where
     ppr (ImportDecl { ideclName = mod', ideclPkgQual = pkg
                     , ideclSource = from, ideclSafe = safe
                     , ideclQualified = qual, ideclImplicit = implicit
@@ -134,12 +134,12 @@ ieNames (IEDocNamed       _   ) = []
 \end{code}
 
 \begin{code}
-instance (Outputable name) => Outputable (IE name) where
-    ppr (IEVar          var)    = pprHsVar var
+instance (OutputableBndr name, Outputable name) => Outputable (IE name) where
+    ppr (IEVar          var)    = pprPrefixOcc var
     ppr (IEThingAbs     thing)  = ppr thing
     ppr (IEThingAll     thing)  = hcat [ppr thing, text "(..)"]
     ppr (IEThingWith thing withs)
-        = pprHsVar thing <> parens (fsep (punctuate comma (map pprHsVar withs)))
+        = pprPrefixOcc thing <> parens (fsep (punctuate comma (map pprPrefixOcc withs)))
     ppr (IEModuleContents mod')
         = ptext (sLit "module") <+> ppr mod'
     ppr (IEGroup n _)           = text ("<IEGroup: " ++ (show n) ++ ">")

compiler/hsSyn/HsUtils.lhs

@@ -233,7 +233,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 
 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
-		       , recS_bind_fn = noSyntaxExpr
+                       , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
                        , recS_rec_rets = [], recS_ret_ty = placeHolderType }
 
 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }

compiler/iface/FlagChecker.hs

@@ -10,6 +10,7 @@ import Binary
 import BinIface ()
 import DynFlags
 import HscTypes
+import Module
 import Name
 import Fingerprint
 -- import Outputable
@@ -21,11 +22,12 @@ import System.FilePath (normalise)
 -- | Produce a fingerprint of a @DynFlags@ value. We only base
 -- the finger print on important fields in @DynFlags@ so that
 -- the recompilation checker can use this fingerprint.
-fingerprintDynFlags :: DynFlags -> (BinHandle -> Name -> IO ())
+fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ())
                     -> IO Fingerprint
 
-fingerprintDynFlags DynFlags{..} nameio =
-    let mainis   = (mainModIs, mainFunIs)
+fingerprintDynFlags DynFlags{..} this_mod nameio =
+    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing
+                      -- see #5878
         -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)
         safeHs   = setSafeMode safeHaskell
         -- oflags   = sort $ filter filterOFlags $ flags dflags
@@ -41,7 +43,9 @@ fingerprintDynFlags DynFlags{..} nameio =
         -- -i, -osuf, -hcsuf, -hisuf, -odir, -hidir, -stubdir, -o, -ohi
         paths = (map normalise importPaths,
                    [ objectSuf, hcSuf, hiSuf ],
-                   [ objectDir, hiDir, stubDir, outputFile, outputHi ])
+                   [ objectDir, hiDir, stubDir, outputHi ])
+                   -- NB. not outputFile, we don't want "ghc --make M -o <file>"
+                   -- to force recompilation when <file> changes.
 
         -- -fprof-auto etc.
         prof = if opt_SccProfilingOn then fromEnum profAuto else 0

compiler/iface/MkIface.lhs

@@ -109,8 +109,8 @@ import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.IORef
+import System.Directory
 import System.FilePath
-import System.Directory (getModificationTime)
 \end{code}
 
 
@@ -286,7 +286,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                         mi_fixities    = fixities,
                         mi_warns       = warns,
                         mi_anns        = mkIfaceAnnotations anns,
-                        mi_globals     = Just rdr_env,
+                        mi_globals     = maybeGlobalRdrEnv rdr_env,
 
                         -- Left out deliberately: filled in by addFingerprints
                         mi_iface_hash  = fingerprint0,
@@ -343,7 +343,7 @@ mkIface_ hsc_env maybe_old_fingerprint
                 -- correctly.  This stems from the fact that the interface had
                 -- not changed, so addFingerprints returns the old ModIface
                 -- with the old GlobalRdrEnv (mi_globals).
-        ; let final_iface = new_iface{ mi_globals = Just rdr_env }
+        ; let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
 
         ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }}
   where
@@ -358,6 +358,17 @@ mkIface_ hsc_env maybe_old_fingerprint
 
      dflags = hsc_dflags hsc_env
 
+     -- We only fill in mi_globals if the module was compiled to byte
+     -- code.  Otherwise, the compiler may not have retained all the
+     -- top-level bindings and they won't be in the TypeEnv (see
+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
+     -- by GHCi to decide whether the module has its full top-level
+     -- scope available.
+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
+     maybeGlobalRdrEnv rdr_env
+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
+         | otherwise                                   = Nothing
+
      deliberatelyOmitted :: String -> a
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
 
@@ -379,7 +390,7 @@ mkIface_ hsc_env maybe_old_fingerprint
 -----------------------------
 writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
 writeIfaceFile dflags location new_iface
-    = do createDirectoryHierarchy (takeDirectory hi_file_path)
+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)
          writeBinIface dflags hi_file_path new_iface
     where hi_file_path = ml_hi_file location
 
@@ -583,7 +594,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
    --   - (some of) dflags
    -- it returns two hashes, one that shouldn't change
    -- the abi hash and one that should
-   flag_hash <- fingerprintDynFlags dflags putNameLiterally
+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
 
    -- the ABI hash depends on:
    --   - decls
@@ -620,7 +631,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_orphan_hash = orphan_hash,
                 mi_flag_hash   = flag_hash,
                 mi_orphan      = not (null orph_rules && null orph_insts
-                                      && null (ifaceVectInfoVar (mi_vect_info iface0))),
+                                      && isNoIfaceVectInfo (mi_vect_info iface0)),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
                 mi_decls       = sorted_decls,
                 mi_hash_fn     = lookupOccEnv local_env }
@@ -1208,7 +1219,9 @@ checkVersions hsc_env mod_summary iface
 checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
 checkFlagHash hsc_env iface = do
     let old_hash = mi_flag_hash iface
-    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) putNameLiterally
+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
+                                             (mi_module iface)
+                                             putNameLiterally
     case old_hash == new_hash of
         True  -> up_to_date (ptext $ sLit "Module flags unchanged")
         False -> out_of_date_hash (ptext $ sLit "  Module flags have changed")

compiler/iface/TcIface.lhs

@@ -733,9 +733,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        ; tyConRes1   <- mapM (vectTyConVectMapping varsSet)  tycons
        ; tyConRes2   <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
        ; vScalarVars <- mapM vectVar                         scalarVars
-       ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
+       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
-                  { vectInfoVar          = mkVarEnv  vVars
+                  { vectInfoVar          = mkVarEnv  vVars `extendVarEnvList` concat vScSels
                   , vectInfoTyCon        = mkNameEnv vTyCons
                   , vectInfoDataCon      = mkNameEnv (concat vDataCons)
                   , vectInfoScalarVars   = mkVarSet  vScalarVars
@@ -753,6 +753,19 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                        tcIfaceExtId vName
            ; return (var, (var, vVar))
            }
+      -- where
+      --   lookupLocalOrExternalId name
+      --     = do { let mb_id = lookupTypeEnv typeEnv name
+      --          ; case mb_id of
+      --                -- id is local
+      --              Just (AnId id) -> return id
+      --                -- name is not an Id => internal inconsistency
+      --              Just _         -> notAnIdErr
+      --                -- Id is external
+      --              Nothing        -> tcIfaceExtId name
+      --          }
+      -- 
+      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
 
     vectVar name 
       = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
@@ -767,13 +780,17 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
       = vectTyConMapping vars name name
 
     vectTyConMapping vars name vName
-      = do { tycon  <- lookupLocalOrExternal name
-           ; vTycon <- lookupLocalOrExternal vName
+      = do { tycon  <- lookupLocalOrExternalTyCon name
+           ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ 
+                         lookupLocalOrExternalTyCon vName
 
-               -- map the data constructors of the original type constructor to those of the
+               -- Map the data constructors of the original type constructor to those of the
                -- vectorised type constructor /unless/ the type constructor was vectorised
                -- abstractly; if it was vectorised abstractly, the workers of its data constructors
-               -- do not appear in the set of vectorised variables
+               -- do not appear in the set of vectorised variables.
+               --
+               -- NB: This is lazy!  We don't pull at the type constructors before we actually use
+               --     the data constructor mapping.
            ; let isAbstract | isClassTyCon tycon = False
                             | datacon:_ <- tyConDataCons tycon 
                                                  = not $ dataConWrapId datacon `elemVarSet` vars
@@ -784,14 +801,25 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                                                                         (tyConDataCons vTycon)
                                            ]
 
+                   -- Map the (implicit) superclass and methods selectors as they don't occur in
+                   -- the var map.
+                 vScSels    | Just cls  <- tyConClass_maybe tycon
+                            , Just vCls <- tyConClass_maybe vTycon 
+                            = [ (sel, (sel, vSel))
+                              | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
+                              ]
+                            | otherwise
+                            = []
+
            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                     , vDataCons                        -- list of (Ci, Ci_v)
+                    , vScSels                          -- list of (seli, seli_v)
                     )
            }
       where
           -- we need a fully defined version of the type constructor to be able to extract
           -- its data constructors etc.
-        lookupLocalOrExternal name
+        lookupLocalOrExternalTyCon name
           = do { let mb_tycon = lookupTypeEnv typeEnv name
                ; case mb_tycon of
                      -- tycon is local

compiler/llvmGen/Llvm.hs

@@ -20,6 +20,9 @@ module Llvm (
         LlvmBlocks, LlvmBlock(..), LlvmBlockId,
         LlvmParamAttr(..), LlvmParameter,
 
+        -- * Fence synchronization
+        LlvmSyncOrdering(..),
+
         -- * Call Handling
         LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
         LlvmLinkageType(..), LlvmFuncAttr(..),

compiler/llvmGen/Llvm/AbsSyn.hs

@@ -59,8 +59,24 @@ data LlvmFunction = LlvmFunction {
     funcBody  :: LlvmBlocks
   }
 
-type LlvmFunctions  = [LlvmFunction]
-
+type LlvmFunctions = [LlvmFunction]
+
+-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
+-- 3.0). Please see the LLVM documentation for a better description.
+data LlvmSyncOrdering
+  -- | Some partial order of operations exists.
+  = SyncUnord
+  -- | A single total order for operations at a single address exists.
+  | SyncMonotonic
+  -- | Acquire synchronization operation.
+  | SyncAcquire
+  -- | Release synchronization operation.
+  | SyncRelease
+  -- | Acquire + Release synchronization operation.
+  | SyncAcqRel
+  -- | Full sequential Consistency operation.
+  | SyncSeqCst
+  deriving (Show, Eq)
 
 -- | Llvm Statements
 data LlvmStatement
@@ -71,6 +87,11 @@ data LlvmStatement
   -}
   = Assignment LlvmVar LlvmExpression
 
+  {- |
+    Memory fence operation
+  -}
+  | Fence Bool LlvmSyncOrdering
+
   {- |
     Always branch to the target label
   -}

compiler/llvmGen/Llvm/PpLlvm.hs

@@ -166,6 +166,7 @@ ppLlvmStatement :: LlvmStatement -> Doc
 ppLlvmStatement stmt
   = case stmt of
         Assignment  dst expr      -> ppAssignment dst (ppLlvmExpression expr)
+        Fence       st ord        -> ppFence st ord
         Branch      target        -> ppBranch target
         BranchIf    cond ifT ifF  -> ppBranchIf cond ifT ifF
         Comment     comments      -> ppLlvmComments comments
@@ -254,6 +255,19 @@ ppCmpOp op left right =
 ppAssignment :: LlvmVar -> Doc -> Doc
 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
 
+ppFence :: Bool -> LlvmSyncOrdering -> Doc
+ppFence st ord =
+  let singleThread = case st of True  -> text "singlethread"
+                                False -> empty
+  in text "fence" <+> singleThread <+> ppSyncOrdering ord
+
+ppSyncOrdering :: LlvmSyncOrdering -> Doc
+ppSyncOrdering SyncUnord     = text "unordered"
+ppSyncOrdering SyncMonotonic = text "monotonic"
+ppSyncOrdering SyncAcquire   = text "acquire"
+ppSyncOrdering SyncRelease   = text "release"
+ppSyncOrdering SyncAcqRel    = text "acq_rel"
+ppSyncOrdering SyncSeqCst    = text "seq_cst"
 
 ppLoad :: LlvmVar -> Doc
 ppLoad var = text "load" <+> texts var

compiler/llvmGen/Llvm/Types.hs

@@ -7,6 +7,7 @@ module Llvm.Types where
 #include "HsVersions.h"
 
 import Data.Char
+import Data.Int
 import Data.List (intercalate)
 import Numeric
 
@@ -186,7 +187,9 @@ getPlainName (LMLitVar    x          ) = getLit x
 
 -- | Print a literal value. No type.
 getLit :: LlvmLit -> String
-getLit (LMIntLit   i _       ) = show ((fromInteger i)::Int)
+getLit (LMIntLit i (LMInt 32)) = show (fromInteger i :: Int32)
+getLit (LMIntLit i (LMInt 64)) = show (fromInteger i :: Int64)
+getLit (LMIntLit i _         ) = show (fromInteger i :: Int)
 getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r
 getLit (LMFloatLit r LMDouble) = dToStr r
 getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f

compiler/llvmGen/LlvmCodeGen/CodeGen.hs

@@ -136,16 +136,15 @@ stmtToInstrs env stmt = case stmt of
         -> return (env, unitOL $ Return Nothing, [])
 
 
--- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-              -> CmmReturnInfo -> UniqSM StmtData
-
--- Write barrier needs to be handled specially as it is implemented as an LLVM
--- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier) _ _ _
- | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
-    = return (env, nilOL, [])
- | otherwise = do
+-- | Memory barrier instruction for LLVM >= 3.0
+barrier :: LlvmEnv -> UniqSM StmtData
+barrier env = do
+    let s = Fence False SyncSeqCst
+    return (env, unitOL s, [])
+
+-- | Memory barrier instruction for LLVM < 3.0
+oldBarrier :: LlvmEnv -> UniqSM StmtData
+oldBarrier env = do
     let fname = fsLit "llvm.memory.barrier"
     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
                     FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
@@ -166,6 +165,18 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _
         lmTrue :: LlvmVar
         lmTrue  = mkIntLit i1 (-1)
 
+-- | Foreign Calls
+genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
+              -> CmmReturnInfo -> UniqSM StmtData
+
+-- Write barrier needs to be handled specially as it is implemented as an LLVM
+-- intrinsic function.
+genCall env (CmmPrim MO_WriteBarrier) _ _ _
+ | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
+    = return (env, nilOL, [])
+ | getLlvmVer env > 29 = barrier env
+ | otherwise           = oldBarrier env
+
 -- Handle popcnt function specifically since GHC only really has i32 and i64
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM

compiler/main/CodeOutput.lhs

@@ -24,7 +24,6 @@ import Finder		( mkStubPaths )
 import PprC		( writeCs )
 import CmmLint		( cmmLint )
 import Packages
-import Util
 import OldCmm           ( RawCmmGroup )
 import HscTypes
 import DynFlags
@@ -203,7 +202,7 @@ outputForeignStubs dflags mod location stubs
 	    stub_h_output_w = showSDoc stub_h_output_d
 	-- in
 
-        createDirectoryHierarchy (takeDirectory stub_h)
+        createDirectoryIfMissing True (takeDirectory stub_h)
 
 	dumpIfSet_dyn dflags Opt_D_dump_foreign
                       "Foreign export header file" stub_h_output_d