built bundler & added bundle flow to the parser and compiler

gibbon-compiler/src/Gibbon/Bundler.hs

@@ -0,0 +1,54 @@
+
+module Bundler (bundleModules) where
+import qualified Data.Foldable                   as F
+import qualified Data.Set                        as S
+import           Gibbon.L0.Syntax                as L0
+import           Gibbon.Common
+import           Data.Map                        as M
+import           Data.List                        as L
+import Language.Haskell.Exts (ImportDecl)
+
+
+
+-- main bundler, takes a list of modules and the main module
+bundleModules :: ProgBundle0 a -> PassM Prog0
+bundleModules bundle = do
+    let (ProgBundle modules main) = bundle
+    let (ProgModule main_name (Prog main_defs main_funs main_exp) main_imports) = main
+    let (defs, funs) = F.foldr _bundleModule (main_defs, main_funs) modules
+    return $ Prog defs funs main_exp
+
+-- main bundle fold
+-- builds the full program by folding definitons and functions into the main
+_bundleModule :: ProgModule0 a -> (DDefs0, FunDefs0) -> (DDefs0, FunDefs0)
+_bundleModule (ProgModule mod_name (Prog {ddefs, fundefs}) _) (defs1, funs1) = 
+    -- conflict checking,,, extract definition and function names
+    let ddef_names1 = M.keysSet defs1
+        ddef_names2 = M.keysSet ddefs
+        fn_names1 = M.keysSet funs1
+        fn_names2 = M.keysSet fundefs
+        em1 = S.intersection ddef_names1 ddef_names2
+        em2 = S.intersection fn_names1 fn_names2
+        conflicts1 = F.foldr (\d acc ->
+                    if (ddefs M.! d) /= (defs1 M.! d)
+                        then d : acc
+                        else acc)
+                    [] em1
+        conflicts2 = F.foldr (\f acc ->
+                    if (fundefs M.! f) /= (funs1 M.! f)
+                        then dbgTraceIt
+                                (sdoc ((fundefs M.! f), (funs1 M.! f)))
+                                (f : acc)
+                        else acc)
+                    [] em2
+    in case (conflicts1, conflicts2) of
+        ([], []) ->
+            (M.union ddefs defs1, M.union fundefs funs1)
+        (_x:_xs, _) ->
+            error $
+            "Conflicting definitions of " ++
+            show conflicts1 ++ " found in " ++ mod_name
+        (_, _x:_xs) ->
+            error $
+            "Conflicting definitions of " ++
+            show (S.toList em2) ++ " found in " ++ mod_name

gibbon-compiler/src/Gibbon/Compiler.hs

@@ -4,6 +4,8 @@
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# OPTIONS_GHC -fno-warn-unused-binds #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Redundant return" #-}
 
 -- | The compiler pipeline, assembled from several passes.
 
@@ -53,6 +55,7 @@ import           Gibbon.L1.Interp()
 import           Gibbon.L2.Interp ( Store, emptyStore )
 -- import           Gibbon.TargetInterp (Val (..), execProg)
 
+import           Gibbon.Bundler                     (bundleModules)
 -- Compiler passes
 import qualified Gibbon.L0.Typecheck as L0
 import qualified Gibbon.L0.Specialize2 as L0
@@ -641,8 +644,8 @@ addRedirectionCon p@Prog{ddefs} = do
   return $ p { ddefs = ddefs' }
 
 -- | The main compiler pipeline
-passes :: (Show v) => Config -> L0.Prog0 -> StateT (CompileState v) IO L4.Prog
-passes config@Config{dynflags} l0 = do
+passes :: (Show v) => Config -> L0.ProgBundle0 a -> StateT (CompileState v) IO L4.Prog
+passes config@Config{dynflags} l0_bundle = do
       let isPacked   = gopt Opt_Packed dynflags
           biginf     = gopt Opt_BigInfiniteRegions dynflags
           gibbon1    = gopt Opt_Gibbon1 dynflags
@@ -653,8 +656,13 @@ passes config@Config{dynflags} l0 = do
           opt_layout_global = gopt Opt_Layout_Global dynflags
           use_solver = gopt Opt_Layout_Use_Solver dynflags
           tcProg3     = L3.tcProg isPacked
-      l0 <- go  "freshConstructors" freshConstructors   l0
-      l0 <- go  "renameModules"   moduleRename         l0
+
+      --l0_unbundled <- go  "freshConstructors" freshConstructors   l0_unbundled
+      --l0_unbundled <- go  "renameModules"     moduleRename        l0_unbundled
+
+      -- bundle modules
+      l0 <- go  "bundle modules" bundleModules          l0_bundle
+
       l0 <- go  "freshen"         freshNames            l0
       l0 <- goE0 "typecheck"       L0.tcProg            l0
       l0 <- goE0 "bindLambdas"     L0.bindLambdas       l0

gibbon-compiler/src/Gibbon/HaskellFrontend.hs

@@ -65,7 +65,7 @@ it expects A.B.D to be at A/B/A/B/D.hs.
 [1] https://downloads.haskell.org/ghc/8.6.4/docs/html/users_guide/separate_compilation.html?#the-search-path
 
 -}
-parseFile :: Config -> FilePath -> IO (PassM Prog0)
+parseFile :: Config -> FilePath -> IO (PassM (ProgBundle0 a))
 parseFile cfg path = do
   pstate0_ref <- newIORef emptyParseState
   parseFile' cfg pstate0_ref [] path "Main"
@@ -91,7 +91,7 @@ parseMode =
 
 -- TIMMY - top level comment
 parseFile' ::
-     Config -> IORef ParseState -> [String] -> FilePath -> String -> IO (PassM Prog0)
+     Config -> IORef ParseState -> [String] -> FilePath -> String -> IO (PassM (ProgBundle0 a))
 parseFile' cfg pstate_ref import_route path mod_name = do
   when (gopt Opt_GhcTc (dynflags cfg)) $ typecheckWithGhc cfg path
   str <- readFile path
@@ -228,15 +228,20 @@ getImportMeta imports = do
 -- later passes -> operate on more abstract representations of the program
 -- ========================================================
 
+-------------------------------------------------------------------------------
+-- recursively desugars modules and their imports
+-- stacks into a ProgBundle: a bundle of modules and their main module
+-- each module contains information about it's name, functions & definitions, and import metadata
+-------------------------------------------------------------------------------
+
 desugarModule ::
-     (Show a, Pretty a)
-  => Config
+  Config
   -> IORef ParseState
   -> [String]
   -> FilePath
-  -> Module a
+  -> Module SrcSpanInfo
   -> String
-  -> IO (PassM Prog0)
+  -> IO (PassM (ProgBundle0 SrcSpanInfo))
 desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) mod_name = do
   let type_syns = foldl collectTypeSynonyms M.empty decls
       -- Since top-level functions and their types can't be declared in
@@ -249,35 +254,35 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
   --dbgPrintLn 2 $ "- imports: " ++ (show import_names)
   --dbgPrintLn 2 $ "- aliases: " ++ (show aliases)
   --dbgPrintLn 2 $ "- imports: " ++ (show (getImportMeta imports))
-  imported_progs :: [PassM Prog0] <-
+  imported_progs :: [PassM (ProgBundle0 a)] <-
     mapM (processImport cfg pstate_ref (mod_name : import_route) dir) imports
   toplevels <- catMaybes <$> mapM (collectTopLevel type_syns funtys) decls
   let (defs, _vars, funs, inlines, main, optimizeDcons, userOrderings) =
         foldr classify init_acc toplevels
       userOrderings' = M.fromList $ coalese_constraints userOrderings
-      defs' = M.mapWithKey (\k (DDef _ tyArgs dataCons) -> DDef k tyArgs (L.map (\(constrName, vs) -> ((mod_name ++ "." ++ constrName), vs)) dataCons) ) (M.mapKeys (\k -> toVar (mod_name ++ "." ++ (fromVar k))) defs)
-      funs' = M.mapWithKey (\k funDef -> funDef {funName = k }) (M.mapKeys (\k -> toVar (mod_name ++ "." ++ (fromVar k))) funs) -- can insert function name here
+      --defs' = M.mapWithKey (\k (DDef _ tyArgs dataCons) -> DDef k tyArgs (L.map (\(constrName, vs) -> ((mod_name ++ "." ++ constrName), vs)) dataCons) ) (M.mapKeys (\k -> toVar (mod_name ++ "." ++ (fromVar k))) defs)
+      --funs' = M.mapWithKey (\k funDef -> funDef {funName = k }) (M.mapKeys (\k -> toVar (mod_name ++ "." ++ (fromVar k))) funs) -- can insert function name here
       --funs' = M.map (\funDef -> funDef {funMeta = funMeta {funModule = mod_name}}) funs -- can insert function name here
-      funs'' =
+      funs' =
         foldr
           (\v acc ->
               M.update
                 (\fn@(FunDef {funMeta}) ->
                   Just (fn {funMeta = funMeta {funInline = Inline}}))
                 v
                 acc)
-          funs'
+          funs
           inlines
-      funs''' =
+      funs'' =
         foldr
           (\v acc ->
               M.update
                 (\fn -> Just (addLayoutMetaData fn optimizeDcons))
                 v
                 acc)
-          funs''
+          funs'
           (P.map fst (S.toList optimizeDcons))
-      funs'''' =
+      funs''' =
         foldr
           (\k acc ->
               M.update
@@ -292,9 +297,12 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
                         }))
                 k
                 acc)
-          funs'''
+          funs''
           (M.keys userOrderings')
   imported_progs' <- mapM id imported_progs
+  let bundle = foldr (\(ProgBundle imported_bundle imported_mainmodule) acc -> acc ++ imported_bundle ++ [imported_mainmodule]) [] imported_progs' 
+  pure $ pure $ ProgBundle bundle (ProgModule mod_name (Prog defs funs''' main) imports)
+  {-
   Prog defs'' funs''''' main' <- fillImports (Prog defs' funs''' main) (toVar mod_name) imports imported_progs'
   let (defs0, funs0) =
         foldr
@@ -336,7 +344,8 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
                       show (S.toList em2) ++ " found in " ++ mod_name)
           (defs'', funs''''')
           imported_progs'
-  pure $ pure $ (Prog defs0 funs0 main') --dbgTraceIt (sdoc funs) dbgTraceIt "\n" dbgTraceIt (sdoc funs''') dbgTraceIt (sdoc userOrderings') dbgTraceIt "\n" dbgTraceIt (sdoc userOrderings)
+    -}
+  --pure $ pure $ (Prog defs0 funs0 main') --dbgTraceIt (sdoc funs) dbgTraceIt "\n" dbgTraceIt (sdoc funs''') dbgTraceIt (sdoc userOrderings') dbgTraceIt "\n" dbgTraceIt (sdoc userOrderings)
   where
     init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing, S.empty, [])
     --mod_name = moduleName head_mb
@@ -471,7 +480,7 @@ processImport ::
   -> [String]
   -> FilePath
   -> ImportDecl a
-  -> IO (PassM Prog0)
+  -> IO (PassM (ProgBundle0 a))
 processImport cfg pstate_ref import_route dir decl@ImportDecl {..}
     -- When compiling with Gibbon, we should *NOT* inline things defined in Gibbon.Prim.
   | mod_name == "Gibbon.Prim" = pure (pure (Prog M.empty M.empty Nothing))

gibbon-compiler/src/Gibbon/L0/Syntax.hs

@@ -25,6 +25,8 @@ import           Text.PrettyPrint.HughesPJ      as PP
 
 import           Gibbon.Common                  as C
 import           Gibbon.Language                hiding (UrTy (..))
+import           Language.Haskell.Exts          (ImportDecl)
+
 
 
 --------------------------------------------------------------------------------
@@ -40,6 +42,10 @@ type FunDefs0 = FunDefs Exp0
 
 type Prog0 = Prog Exp0
 
+-------------------------------------------------------------------------------
+
+data ProgModule0 a = ProgModule String Prog0 [ImportDecl a]
+data ProgBundle0 a = ProgBundle [ProgModule0 a] (ProgModule0 a)
 
 --------------------------------------------------------------------------------
 

gibbon-compiler/src/Gibbon/Language/Syntax.hs

@@ -127,6 +127,7 @@ import           System.IO.Unsafe               (unsafePerformIO)
 import           Text.PrettyPrint.GenericPretty
 
 import           Gibbon.Common
+import           Language.Haskell.Exts          (ImportDecl)
 
 
 --------------------------------------------------------------------------------
@@ -392,6 +393,17 @@ data Prog ex =
     , mainExp :: Maybe (ex, (TyOf ex))
     }
 
+-------------------------------------------------------------------------------
+-- Module Bundles
+-- Before modules get bundled into a single program, they're stored as
+-- a tuple of the discrte Prog and it's import declarations
+-------------------------------------------------------------------------------
+
+
+data ProgModule ex a = ProgModule (Prog ex) (ImportDecl a)
+data ProgBundle ex a = ProgBundle [ProgModule ex a] (ProgModule ex a)
+
+-------------------------------------------------------------------------------
 
 -- Since 'FunDef' is defined using a type family, we cannot use the deriving clause.
 -- Ryan Scott recommended using singletons-like alternative outlined here: