Improvements to tail-call-modulo-construction optimization

src/AST.hs

@@ -72,7 +72,7 @@ module AST (
   expOutputs, pexpListOutputs, expInputs, pexpListInputs,
   setExpTypeFlow, setPExpTypeFlow,
   Prim(..), primArgs, replacePrimArgs, argIsVar, argIsConst, argIntegerValue,
-  varsInPrims, varsInPrim, varsInPrimArgs, varsInPrimArg,
+  varsInPrims, varsInPrims', varsInPrim, varsInPrim', varsInPrimArgs, varsInPrimArg,
   ProcSpec(..), PrimVarName(..), PrimArg(..), PrimFlow(..), ArgFlowType(..),
   CallSiteID, SuperprocSpec(..), initSuperprocSpec, -- addSuperprocSpec,
   maybeGetClosureOf, isClosureProc, isClosureVariant,
@@ -116,7 +116,7 @@ module AST (
   maybeShow, showMessages, stopOnError,
   logMsg, whenLogging2, whenLogging,
   -- *Helper functions
-  defaultBlock, moduleIsPackage,
+  moduleIsPackage,
   -- *LPVM Encoding types
   EncodedLPVM(..), makeEncodedLPVM
   ) where
@@ -911,7 +911,7 @@ lookupType :: String -> OptPos -> TypeSpec -> Compiler TypeSpec
 lookupType context pos ty = do
     (msgs, ty') <- lookupType' context pos ty
     mapM_ queueMessage msgs
-    return ty' 
+    return ty'
 
 
 -- |Find the definition of the specified type visible from the current module.
@@ -923,7 +923,7 @@ lookupType' _ _ ty@TypeVariable{} = return ([], ty)
 lookupType' _ _ ty@Representation{} = return ([], ty)
 lookupType' context pos ty@HigherOrderType{higherTypeParams=typeFlows} = do
     (msgs, types) <- unzip <$> mapM (lookupType' context pos . typeFlowType) typeFlows
-    return (concat msgs, 
+    return (concat msgs,
             ty{higherTypeParams=zipWith TypeFlow types (typeFlowMode <$> typeFlows)})
 lookupType' context pos ty@(TypeSpec [] typename args)
   | typename == currentModuleAlias = do
@@ -2358,33 +2358,10 @@ data PrimFork =
     }
     deriving (Eq, Show, Generic)
 
-
-data LLBlock = LLBlock {
-    llInstrs::[LLInstr],
-    llTerm::LLTerm
-    } deriving (Eq, Show)
-
-
-data LLInstr = LLNop
-  -- LLInstr {
-  --   llTarget::Maybe PrimVarName,
-  --   llOpr::[String],
-  --   llOperands::[(PrimVar,PrimType)]
-             deriving (Eq, Show)
-
-
-data LLTerm = TermNop
-            deriving (Eq, Show)
-
 -- |The variable name for the temporary variable whose number is given.
 mkTempName :: Int -> String
 mkTempName ctr = specialName2 "tmp" $ show ctr
 
--- |Make a default LLBlock
-defaultBlock :: LLBlock
-defaultBlock =  LLBlock { llInstrs = [], llTerm = TermNop }
-
-
 -- |Fold over a list of statements in a pre-order left-to-right traversal.
 -- Takes two folding functions, one for statements and one for expressions.
 foldStmts :: (a -> Stmt -> OptPos -> a) -> (a -> Exp -> OptPos -> a) -> a
@@ -3468,22 +3445,29 @@ setPExpTypeFlow typeflow pexpr = setExpTypeFlow typeflow <$> pexpr
 -- or definitions.
 ----------------------------------------------------------------
 
-varsInPrims :: PrimFlow -> [Prim] -> Set PrimVarName
-varsInPrims dir =
-    List.foldr (Set.union . (varsInPrim dir)) Set.empty
+varsInPrims :: (PrimFlow -> Bool) -> [Prim] -> Set PrimVarName
+varsInPrims tst =
+    List.foldr (Set.union . varsInPrim' (\flow final -> tst flow)) Set.empty
+
+varsInPrim :: (PrimFlow -> Bool) -> Prim     -> Set PrimVarName
+varsInPrim tst = varsInPrim' (\flow final -> tst flow)
+
+varsInPrims' :: (PrimFlow -> Bool -> Bool) -> [Prim] -> Set PrimVarName
+varsInPrims' tst =
+    List.foldr (Set.union . varsInPrim' tst) Set.empty
 
-varsInPrim :: PrimFlow -> Prim     -> Set PrimVarName
-varsInPrim dir prim      = let (args, globals) = primArgs prim in varsInPrimArgs dir args
+varsInPrim' :: (PrimFlow -> Bool -> Bool) -> Prim     -> Set PrimVarName
+varsInPrim' tst prim      = let (args, globals) = primArgs prim in varsInPrimArgs tst args
 
-varsInPrimArgs :: PrimFlow -> [PrimArg] -> Set PrimVarName
-varsInPrimArgs dir =
-    List.foldr (Set.union . varsInPrimArg dir) Set.empty
+varsInPrimArgs :: (PrimFlow -> Bool -> Bool) -> [PrimArg] -> Set PrimVarName
+varsInPrimArgs tst =
+    List.foldr (Set.union . varsInPrimArg tst) Set.empty
 
-varsInPrimArg :: PrimFlow -> PrimArg -> Set PrimVarName
-varsInPrimArg dir ArgVar{argVarName=var,argVarFlow=dir'}
-    = if dir == dir' then Set.singleton var else Set.empty
-varsInPrimArg dir (ArgClosure _ as _)
-    = Set.unions $ Set.fromList (varsInPrimArg dir <$> as)
+varsInPrimArg :: (PrimFlow -> Bool -> Bool) -> PrimArg -> Set PrimVarName
+varsInPrimArg tst ArgVar{argVarName=var,argVarFlow=dir, argVarFinal=final}
+    = if tst dir final then Set.singleton var else Set.empty
+varsInPrimArg tst (ArgClosure _ as _)
+    = Set.unions $ Set.fromList (varsInPrimArg tst <$> as)
 varsInPrimArg _ ArgInt{}      = Set.empty
 varsInPrimArg _ ArgFloat{}    = Set.empty
 varsInPrimArg _ ArgString{}   = Set.empty

src/AliasAnalysis.hs

@@ -278,11 +278,11 @@ updateAliasedByPrim aliasMap prim =
             logAlias $ "args: " ++ show args
             logAlias $ "paramArgMap: " ++ show paramArgMap
             let calleeArgsAliases =
-                    mapDS (\x -> Map.lookup x paramArgMap) calleeParamAliases
+                    mapDS (`Map.lookup` paramArgMap) calleeParamAliases
                     -- filter out aliases of constant args
                     -- (caused by constant constructor)
                     |> filterDS isJust
-                    |> mapDS (\x -> LiveVar (fromJust x))
+                    |> mapDS (LiveVar . fromJust)
             combined <- aliasedArgsInPrimCall calleeArgsAliases aliasMap args
             logAlias $ "calleeParamAliases: " ++ show calleeParamAliases
             logAlias $ "calleeArgsAliases:  " ++ show calleeArgsAliases
@@ -538,8 +538,8 @@ isArgVarUsedOnceInArgs _ _ _ = True -- we don't care about constant value
 addInterestingUnaliasedParams :: PrimProto -> Set InterestingCallProperty
         -> [PrimVarName] -> Set InterestingCallProperty
 addInterestingUnaliasedParams proto properties params =
-    List.map (InterestingUnaliased . (parameterVarNameToID proto)) params
-    |> (List.foldr Set.insert) properties
+    List.map (InterestingUnaliased . parameterVarNameToID proto) params
+    |> List.foldr Set.insert properties
 
 
 -- adding new specz version dependency