Free name removal

fco2/AST.hs

@@ -22,6 +22,7 @@ data NameDef = NameDef {
     ndMeta :: Meta,
     ndName :: String,
     ndOrigName :: String,
+    ndNameType :: NameType,
     ndType :: SpecType,
     ndAbbrevMode :: AbbrevMode
   }

fco2/GenerateC.hs

@@ -432,7 +432,7 @@ genProcess p = case p of
   A.If m s -> genIf s
   --A.Case m e s
   A.While m e p -> genWhile e p
-  --A.Par m pm ps
+  A.Par m pm ps -> genPar pm ps
   --A.ParRep m pm r p
   --A.Processor m e p
   --A.Alt m b s
@@ -528,6 +528,13 @@ genWhile e p
           genProcess p
           tell ["}\n"]
 
+-- FIXME Stubbed out for now so I can see what the branches look like...
+genPar :: A.ParMode -> [A.Process] -> CGen ()
+genPar pm ps
+    =  do tell ["#error PAR not implemented\n"]
+          sequence_ $ map genProcess ps
+          tell ["#error end PAR\n"]
+
 genProcCall :: A.Name -> [A.Actual] -> CGen ()
 genProcCall n as
     =  do genName n

fco2/Parse.hs

@@ -328,6 +328,7 @@ scopeIn n@(A.Name m nt s) t am
             A.ndMeta = m,
             A.ndName = s',
             A.ndOrigName = s,
+            A.ndNameType = A.nameType n',
             A.ndType = t,
             A.ndAbbrevMode = am
           }

fco2/Types.hs

@@ -14,6 +14,18 @@ perhapsM m f
 perhaps :: Maybe a -> (a -> b) -> Maybe b
 perhaps m f = m `perhapsM` (Just . f)
 
+-- FIXME: Eww, this shouldn't be necessary -- the lookups should really work on
+-- Strings.
+makeDummyName :: String -> A.Name
+makeDummyName s = A.Name {
+                    A.nameMeta = [],
+                    A.nameType = A.ChannelName,
+                    A.nameName = s
+                  }
+
+sameName :: A.Name -> A.Name -> Bool
+sameName a b = A.nameName a == A.nameName b
+
 specTypeOfName :: ParseState -> A.Name -> Maybe A.SpecType
 specTypeOfName ps n
     = (psLookupName ps n) `perhaps` A.ndType

fco2/Unnest.hs

@@ -3,6 +3,8 @@ module Unnest where
 
 import Control.Monad.State
 import Data.Generics
+import qualified Data.Map as Map
+import Data.Maybe
 
 import qualified AST as A
 import Metadata
@@ -20,7 +22,8 @@ makeNonceProc m p
           let nd = A.NameDef {
                      A.ndMeta = m,
                      A.ndName = ns,
-                     A.ndOrigName = "PAR branch",
+                     A.ndOrigName = ns,
+                     A.ndNameType = A.ProcName,
                      A.ndType = st,
                      A.ndAbbrevMode = A.Abbrev
                    }
@@ -30,8 +33,9 @@ makeNonceProc m p
 unnest :: ParseState -> A.Process -> IO (ParseState, A.Process)
 unnest ps ast
     =  do (ast', ps') <- runStateT (parsToProcs ast) ps
-          (ast'', ps'') <- runStateT (removeNesting ast') ps'
-          return (ps'', ast'')
+          (ast'', ps'') <- runStateT (removeFreeNames ast') ps'
+          (ast''', ps''') <- runStateT (removeNesting ast'') ps''
+          return (ps''', ast''')
 
 -- | Wrap the subprocesses of PARs in no-arg PROCs.
 parsToProcs :: Data t => t -> UnM t
@@ -54,7 +58,128 @@ parsToProcs = doGeneric `extM` doProcess
               return $ A.ParRep m pm rep' call
     doProcess p = doGeneric p
 
+type NameMap = Map.Map String A.Name
+
+-- | Get the set of free names within a block of code.
+freeNamesIn :: Data t => t -> NameMap
+freeNamesIn = doGeneric `extQ` doName `extQ` doProcess `extQ` doStructured `extQ` doValueProcess `extQ` doSpecType
+  where
+    doGeneric :: Data t => t -> NameMap
+    doGeneric n = Map.unions $ gmapQ freeNamesIn n
+
+    -- FIXME This won't do the right thing with tags.
+    doName :: A.Name -> NameMap
+    doName n = Map.singleton (A.nameName n) n
+
+    doProcess :: A.Process -> NameMap
+    doProcess (A.ProcSpec _ spec p) = doSpec spec p
+    doProcess (A.SeqRep _ rep p) = doRep rep p
+    doProcess (A.ParRep _ _ rep p) = doRep rep p
+    doProcess p = doGeneric p
+
+    doStructured :: A.Structured -> NameMap
+    doStructured (A.Rep _ rep s) = doRep rep s
+    doStructured (A.Spec _ spec s) = doSpec spec s
+    doStructured s = doGeneric s
+
+    doValueProcess :: A.ValueProcess -> NameMap
+    doValueProcess (A.ValOfSpec _ spec vp) = doSpec spec vp
+    doValueProcess vp = doGeneric vp
+
+    doSpec :: Data t => A.Specification -> t -> NameMap
+    doSpec (n, st) child
+        = Map.union fns $ Map.delete (A.nameName n) $ freeNamesIn child
+      where
+        fns = freeNamesIn st
+
+    doRep :: Data t => A.Replicator -> t -> NameMap
+    doRep rep child
+        = Map.union fns $ Map.delete (A.nameName repName) $ freeNamesIn child
+      where
+        (repName, fns) = case rep of
+          A.For _ n b c -> (n, Map.union (freeNamesIn b) (freeNamesIn c))
+
+    doSpecType :: A.SpecType -> NameMap
+    doSpecType (A.Proc _ fs p) = Map.difference (freeNamesIn p) (freeNamesIn fs)
+    doSpecType (A.Function _ _ fs vp) = Map.difference (freeNamesIn vp) (freeNamesIn fs)
+    doSpecType st = doGeneric st
+
+-- | Turn free names in PROCs into arguments.
+removeFreeNames :: Data t => t -> UnM t
+removeFreeNames = doGeneric `extM` doProcess `extM` doStructured `extM` doValueProcess
+  where
+    doGeneric :: Data t => t -> UnM t
+    doGeneric = gmapM removeFreeNames
+
+    doProcess :: A.Process -> UnM A.Process
+    doProcess (A.ProcSpec m spec p)
+        =  do (spec', p') <- doSpec m spec p
+              return $ A.ProcSpec m spec' p'
+    doProcess p = doGeneric p
+
+    doStructured :: A.Structured -> UnM A.Structured
+    doStructured (A.Spec m spec s)
+        =  do (spec', s') <- doSpec m spec s
+              return $ A.Spec m spec' s'
+    doStructured s = doGeneric s
+
+    doValueProcess :: A.ValueProcess -> UnM A.ValueProcess
+    doValueProcess (A.ValOfSpec m spec vp)
+        =  do (spec', vp') <- doSpec m spec vp
+              return $ A.ValOfSpec m spec' vp'
+    doValueProcess vp = doGeneric vp
+
+    addToCalls :: Data t => A.Name -> [A.Actual] -> t -> t
+    addToCalls matchN newAs = everywhere (mkT atcProc)
+      where
+        atcProc :: A.Process -> A.Process
+        atcProc p@(A.ProcCall m n as)
+            = if sameName n matchN then A.ProcCall m n (as ++ newAs) else p
+        atcProc p = p
+
+    doSpec :: Data t => Meta -> A.Specification -> t -> UnM (A.Specification, t)
+    doSpec m spec child = case spec of
+        (n, st@(A.Proc m fs p)) ->
+          do
+             -- Figure out the free names
+             let allFreeNames = Map.elems $ freeNamesIn st
+             let freeNames = [n | n <- allFreeNames,
+                                  case A.nameType n of
+                                    A.ChannelName -> True
+                                    A.VariableName -> True
+                                    _ -> False]
+             ps <- get
+             let types = [fromJust $ typeOfName ps n | n <- freeNames]
+             -- Add formals for each of the free names
+             let newFs = [A.Formal A.Abbrev t n | (t, n) <- zip types freeNames]
+             p' <- removeFreeNames p
+             let spec' = (n, A.Proc m (fs ++ newFs) p')
+             -- Add extra arguments to calls of this proc
+             let newAs = [case A.nameType n of
+                            A.ChannelName -> A.ActualChannel (A.Channel m n)
+                            A.VariableName -> A.ActualExpression (A.ExprVariable m (A.Variable m n))
+                            _ -> error $ "not handled: " ++ show n
+                          | (t, n) <- zip types freeNames]
+             child' <- removeFreeNames (addToCalls n newAs child)
+             return (spec', child')
+        _ ->
+          do spec' <- removeFreeNames spec
+             child' <- removeFreeNames child
+             return (spec', child')
+
 -- | Pull nested declarations to the top level.
 removeNesting :: Data t => t -> UnM t
-removeNesting p = return p
+removeNesting = doGeneric `extM` doProcess `extM` doStructured `extM` doValueProcess
+  where
+    doGeneric :: Data t => t -> UnM t
+    doGeneric = gmapM removeNesting
+
+    doProcess :: A.Process -> UnM A.Process
+    doProcess p = doGeneric p
+
+    doStructured :: A.Structured -> UnM A.Structured
+    doStructured s = doGeneric s
+
+    doValueProcess :: A.ValueProcess -> UnM A.ValueProcess
+    doValueProcess vp = doGeneric vp
 

fco2/testcases/nesting.occ

@@ -0,0 +1,15 @@
+PROC outer (CHAN OF INT channel)
+  VAL INT constant IS 42:
+  INT count:
+  PROC inner1 ()
+    count := count + constant
+  :
+  PROC inner2 (VAL INT count)
+    SEQ i = 0 FOR constant
+      channel ! count + i
+  :
+  SEQ
+    count := 0
+    inner1 ()
+    inner2 (count)
+: