Merge branch 'master' of http://darcs.haskell.org/ghc
authorIan Lynagh <igloo@earth.li>
Fri, 10 Jun 2011 17:39:53 +0000 (18:39 +0100)
committerIan Lynagh <igloo@earth.li>
Fri, 10 Jun 2011 17:39:53 +0000 (18:39 +0100)
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/deSugar/Desugar.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SimplCore.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcRnMonad.lhs

index 88509f9..c130921 100644 (file)
@@ -15,27 +15,28 @@ Taken quite directly from the Peyton Jones/Lester paper.
 -- | A module concerned with finding the free variables of an expression.
 module CoreFVs (
         -- * Free variables of expressions and binding groups
-       exprFreeVars,   -- CoreExpr   -> VarSet -- Find all locally-defined free Ids or tyvars
-       exprFreeIds,    -- CoreExpr   -> IdSet  -- Find all locally-defined free Ids
-       exprsFreeVars,  -- [CoreExpr] -> VarSet
-       bindFreeVars,   -- CoreBind   -> VarSet
+        exprFreeVars,   -- CoreExpr   -> VarSet -- Find all locally-defined free Ids or tyvars
+        exprFreeIds,    -- CoreExpr   -> IdSet  -- Find all locally-defined free Ids
+        exprsFreeVars,  -- [CoreExpr] -> VarSet
+        bindFreeVars,   -- CoreBind   -> VarSet
 
         -- * Selective free variables of expressions
         InterestingVarFun,
-       exprSomeFreeVars, exprsSomeFreeVars,
+        exprSomeFreeVars, exprsSomeFreeVars,
 
         -- * Free variables of Rules, Vars and Ids
         varTypeTyVars, varTypeTcTyVars, 
-       idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
+        idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
         idRuleVars, idRuleRhsVars, stableUnfoldingVars,
-       ruleRhsFreeVars, rulesFreeVars,
-       ruleLhsOrphNames, ruleLhsFreeIds, 
+        ruleRhsFreeVars, rulesFreeVars,
+        ruleLhsOrphNames, ruleLhsFreeIds, 
+        vectsFreeVars,
 
         -- * Core syntax tree annotation with free variables
-       CoreExprWithFVs,        -- = AnnExpr Id VarSet
-       CoreBindWithFVs,        -- = AnnBind Id VarSet
-       freeVars,               -- CoreExpr -> CoreExprWithFVs
-       freeVarsOf              -- CoreExprWithFVs -> IdSet
+        CoreExprWithFVs,        -- = AnnExpr Id VarSet
+        CoreBindWithFVs,        -- = AnnBind Id VarSet
+        freeVars,               -- CoreExpr -> CoreExprWithFVs
+        freeVarsOf              -- CoreExprWithFVs -> IdSet
     ) where
 
 #include "HsVersions.h"
@@ -268,9 +269,9 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
 \end{code}
 
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -278,7 +279,7 @@ exprsOrphNames es = foldr (unionNameSets . exprOrphNames) emptyNameSet es
 ruleRhsFreeVars :: CoreRule -> VarSet
 ruleRhsFreeVars (BuiltinRule {}) = noFVs
 ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
-  = delFromUFM fvs fn   -- Note [Rule free var hack]
+  = delFromUFM fvs fn    -- Note [Rule free var hack]
   where
     fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
 
@@ -286,7 +287,7 @@ ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs })
 ruleFreeVars :: CoreRule -> VarSet
 ruleFreeVars (BuiltinRule {}) = noFVs
 ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args })
-  = delFromUFM fvs fn  -- Note [Rule free var hack]
+  = delFromUFM fvs fn   -- Note [Rule free var hack]
   where
     fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet
 
@@ -298,8 +299,8 @@ idRuleRhsVars is_active id
     get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
                   , ru_rhs = rhs, ru_act = act })
       | is_active act
-           -- See Note [Finding rule RHS free vars] in OccAnal.lhs
-      = delFromUFM fvs fn       -- Note [Rule free var hack]
+            -- See Note [Finding rule RHS free vars] in OccAnal.lhs
+      = delFromUFM fvs fn        -- Note [Rule free var hack]
       where
         fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet
     get_fvs _ = noFVs
@@ -315,19 +316,31 @@ ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })
   = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet
 \end{code}
 
+
 Note [Rule free var hack]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Don't include the Id in its own rhs free-var set.
 Otherwise the occurrence analyser makes bindings recursive
 that shoudn't be.  E.g.
-       RULE:  f (f x y) z  ==>  f x (f y z)
+        RULE:  f (f x y) z  ==>  f x (f y z)
 
 Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM.
 
+
+\begin{code}
+-- |Free variables of a vectorisation declaration
+vectsFreeVars :: [CoreVect] -> VarSet
+vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
+  where
+    vectFreeVars (Vect _ Nothing)    = noFVs
+    vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
+\end{code}
+
+
 %************************************************************************
-%*                                                                     *
+%*                                                                      *
 \section[freevars-everywhere]{Attaching free variables to every sub-expression}
-%*                                                                     *
+%*                                                                      *
 %************************************************************************
 
 The free variable pass annotates every node in the expression with its
index 047e6c3..acf17e3 100644 (file)
@@ -692,16 +692,16 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 --    - Rules for *imported* Ids never change ru_fn
 --    - Rules for *local* Ids are in the IdInfo for that Id,
 --      and the ru_fn field is simply replaced by the new name 
---     of the Id
+--      of the Id
 substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
                                        , ru_fn = fn_name, ru_rhs = rhs
                                        , ru_local = is_local })
   = rule { ru_bndrs = bndrs', 
-          ru_fn    = if is_local 
-                       then subst_ru_fn fn_name 
-                       else fn_name,
-          ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
+           ru_fn    = if is_local 
+                        then subst_ru_fn fn_name 
+                        else fn_name,
+           ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
            ru_rhs   = simpleOptExprWith subst' rhs }
            -- Do simple optimisation on RHS, in case substitution lets
            -- you improve it.  The real simplifier never gets to look at it.
@@ -709,13 +709,22 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
     (subst', bndrs') = substBndrs subst bndrs
 
 ------------------
+substVects :: Subst -> [CoreVect] -> [CoreVect]
+substVects subst = map (substVect subst)
+
+------------------
+substVect :: Subst -> CoreVect -> CoreVect
+substVect _subst (Vect v Nothing)    = Vect v Nothing
+substVect subst  (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
+
+------------------
 substVarSet :: Subst -> VarSet -> VarSet
 substVarSet subst fvs
   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
   where
     subst_fv subst fv 
-       | isId fv   = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
-       | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
+        | isId fv   = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv)
+        | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv)
 \end{code}
 
 Note [Worker inlining]
@@ -766,15 +775,16 @@ simpleOptExprWith :: Subst -> InExpr -> OutExpr
 simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr)
 
 ----------------------
-simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
-simpleOptPgm dflags binds rules
+simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> [CoreVect] 
+             -> IO ([CoreBind], [CoreRule], [CoreVect])
+simpleOptPgm dflags binds rules vects
   = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
-                      (pprCoreBindings occ_anald_binds);
+                       (pprCoreBindings occ_anald_binds);
 
-       ; return (reverse binds', substRulesForImportedIds subst' rules) }
+       ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) }
   where
     occ_anald_binds  = occurAnalysePgm Nothing {- No rules active -}
-                                       rules binds
+                                       rules vects binds
     (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
                        
     do_one (subst, binds') bind 
index 7b008e9..70679fb 100644 (file)
@@ -116,35 +116,36 @@ deSugar hsc_env
 
         ; case mb_res of {
            Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, ds_vects, ds_fords,ds_hpc_info, modBreaks) -> do
+           Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do
 
-       {       -- Add export flags to bindings
-         keep_alive <- readIORef keep_var
-       ; let (rules_for_locals, rules_for_imps) 
+        {       -- Add export flags to bindings
+          keep_alive <- readIORef keep_var
+        ; let (rules_for_locals, rules_for_imps) 
                    = partition isLocalRule all_rules
               final_prs = addExportFlagsAndRules target
-                             export_set keep_alive rules_for_locals (fromOL all_prs)
+                              export_set keep_alive rules_for_locals (fromOL all_prs)
 
               final_pgm = combineEvBinds ds_ev_binds final_prs
-       -- Notice that we put the whole lot in a big Rec, even the foreign binds
-       -- When compiling PrelFloat, which defines data Float = F# Float#
-       -- we want F# to be in scope in the foreign marshalling code!
-       -- You might think it doesn't matter, but the simplifier brings all top-level
-       -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+        -- Notice that we put the whole lot in a big Rec, even the foreign binds
+        -- When compiling PrelFloat, which defines data Float = F# Float#
+        -- we want F# to be in scope in the foreign marshalling code!
+        -- You might think it doesn't matter, but the simplifier brings all top-level
+        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-       -- Lint result if necessary, and print
+        -- Lint result if necessary, and print
         ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
                (vcat [ pprCoreBindings final_pgm
                      , pprRules rules_for_imps ])
 
-       ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
-                        -- The simpleOptPgm gets rid of type 
-                        -- bindings plus any stupid dead code
+        ; (ds_binds, ds_rules_for_imps, ds_vects) 
+            <- simpleOptPgm dflags final_pgm rules_for_imps vects0
+                         -- The simpleOptPgm gets rid of type 
+                         -- bindings plus any stupid dead code
 
-       ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
+        ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 
         ; let used_names = mkUsedNames tcg_env
-       ; deps <- mkDependencies tcg_env
+        ; deps <- mkDependencies tcg_env
 
         ; let mod_guts = ModGuts {     
                mg_module       = mod,
index ba7d192..06133d6 100644 (file)
@@ -53,13 +53,14 @@ import Data.List
 Here's the externally-callable interface:
 
 \begin{code}
-occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule]
+occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] -> [CoreVect]
                 -> [CoreBind] -> [CoreBind]
-occurAnalysePgm active_rule imp_rules binds
+occurAnalysePgm active_rule imp_rules vects binds
   = snd (go (initOccEnv active_rule imp_rules) binds)
   where
-    initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules)
-    -- The RULES keep things alive!
+    initial_uds = addIdOccs emptyDetails 
+                            (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects)
+    -- The RULES and VECTORISE declarations keep things alive!
 
     go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
     go _ []
index ea81317..23a2472 100644 (file)
@@ -358,7 +358,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
       = do {
                -- Occurrence analysis
           let { tagged_binds = {-# SCC "OccAnal" #-} 
-                     occurAnalysePgm active_rule rules binds } ;
+                     occurAnalysePgm active_rule rules [] binds } ;
           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
                     (pprCoreBindings tagged_binds);
 
index 8462403..2eefb8c 100644 (file)
@@ -575,12 +575,13 @@ impSpecErr name
                , ptext (sLit "(or you compiled its defining module without -O)")])
 
 --------------
-tcVectDecls :: [LVectDecl Name] -> TcM [LVectDecl TcId]
+tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId])
 tcVectDecls decls 
   = do { decls' <- mapM (wrapLocM tcVect) decls
        ; let ids  = [unLoc id | L _ (HsVect id _) <- decls']
              dups = findDupsEq (==) ids
        ; mapM_ reportVectDups dups
+       ; traceTcConstraints "End of tcVectDecls"
        ; return decls'
        }
   where
@@ -598,7 +599,7 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId)
 tcVect (HsVect name Nothing)
   = addErrCtxt (vectCtxt name) $
     do { id <- wrapLocM tcLookupId name
-       ; return (HsVect id Nothing)
+       ; return $ HsVect id Nothing
        }
 tcVect (HsVect name@(L loc _) (Just rhs))
   = addErrCtxt (vectCtxt name) $
@@ -613,9 +614,10 @@ tcVect (HsVect name@(L loc _) (Just rhs))
        ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
 
        ; traceTc "tcVect inferred type" $ ppr (varType id')
+       ; traceTc "tcVect bindings"      $ ppr binds
        
-         -- add the type variable and dictionary bindings produced by type generalisation to the
-         -- right-hand side of the vectorisation declaration
+         -- add all bindings, including the type variable and dictionary bindings produced by type
+         -- generalisation to the right-hand side of the vectorisation declaration
        ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds
        ; let [bind']                                  = bagToList actualBinds
              MatchGroup 
index 46624c5..ce84178 100644 (file)
@@ -990,10 +990,10 @@ captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 -- (captureConstraints m) runs m, and returns the type constraints it generates
 captureConstraints thing_inside
   = do { lie_var <- newTcRef emptyWC ;
-        res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
-                         thing_inside ;
-        lie <- readTcRef lie_var ;
-        return (res, lie) }
+         res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
+                          thing_inside ;
+         lie <- readTcRef lie_var ;
+         return (res, lie) }
 
 captureUntouchables :: TcM a -> TcM (a, Untouchables)
 captureUntouchables thing_inside
@@ -1018,14 +1018,21 @@ setLclTypeEnv lcl_env thing_inside
   = updLclEnv upd thing_inside
   where
     upd env = env { tcl_env = tcl_env lcl_env,
-                   tcl_tyvars = tcl_tyvars lcl_env }
+                    tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+  = do { lie_var <- getConstraintVar
+       ; lie     <- readTcRef lie_var
+       ; traceTc (msg ++ "LIE:") (ppr lie)
+       }
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
-            Template Haskell context
-%*                                                                     *
+%*                                                                      *
+             Template Haskell context
+%*                                                                      *
 %************************************************************************
 
 \begin{code}