merged in main

gibbon-compiler/examples/poly/Poly1.ans

@@ -1 +1 @@
-'#(10 #t 11 #f 2 4 (Nothing99_v323) (Right98_v342 20) (Right98_v334 1) 12 #f 0 3 (Cons96_v329 1 (Cons96_v329 2 (Nil95_v329))) (Cons96_v329 1 (Cons96_v329 2 (Nil95_v329))) (Right98_v334 1) (Cons96_v329 11 (Cons96_v329 12 (Nil95_v329))))
+'#(10 #t 11 #f 2 4 (Nothing99_v434) (Right98_v453 20) (Right98_v445 1) 12 #f 0 3 (Cons96_v440 1 (Cons96_v440 2 (Nil95_v440))) (Cons96_v440 1 (Cons96_v440 2 (Nil95_v440))) (Right98_v445 1) (Cons96_v440 11 (Cons96_v440 12 (Nil95_v440))))

gibbon-compiler/examples/test_153.ans

@@ -1 +1 @@
-'#((A6_v15 2 3) (B5_v16 4 5))
+'#('#(2 3) (B5_v17 4 5))

gibbon-compiler/examples/test_164.ans

@@ -1 +1 @@
-(Cons19_v50 3 (Cons19_v50 5 (Cons19_v50 7 (Nil18_v50))))
+(Cons19_v68 3 (Cons19_v68 5 (Cons19_v68 7 (Nil18_v68))))

gibbon-compiler/examples/test_166.ans

@@ -1 +1 @@
-(Node16_v61 10 10 10 10 10 10 10 10 (Cell15_v61 5 5 5 5 5 5 5 5) (Cell15_v61 2 2 2 2 2 2 2 2))
+(Node16_v86 10 10 10 10 10 10 10 10 (Cell15_v86 5 5 5 5 5 5 5 5) (Cell15_v86 2 2 2 2 2 2 2 2))

gibbon-compiler/src/Gibbon/Bundler.hs

@@ -14,7 +14,7 @@ import           Data.Map                        as M
 bundleModules :: ProgBundle0 -> 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 (ProgModule _ (Prog main_defs main_funs main_exp) _) = main
     let (defs, funs) = F.foldr _bundleModule (main_defs, main_funs) modules
     return $ Prog defs funs main_exp
 

gibbon-compiler/src/Gibbon/HaskellFrontend.hs

@@ -14,7 +14,7 @@ module Gibbon.HaskellFrontend
 
 import           Control.Monad
 import           Data.Foldable ( foldrM, foldl' )
-import           Data.Maybe (catMaybes, isJust)
+import           Data.Maybe (catMaybes)
 import qualified Data.Map as M
 import qualified Data.Set as S
 import           Data.IORef
@@ -23,7 +23,8 @@ import           Language.Haskell.Exts.Parser
 import           Language.Haskell.Exts.Syntax as H
 import           Language.Haskell.Exts.Pretty
 import           Language.Haskell.Exts.SrcLoc
-import           Language.Haskell.Exts.CPP
+import Language.Haskell.Exts.CPP
+    ( parseFileContentsWithCommentsAndCPP, defaultCpphsOptions )
 import           System.Environment ( getEnvironment )
 import           System.Directory
 import           System.FilePath
@@ -34,9 +35,8 @@ import           System.IO
 import           Gibbon.L0.Syntax as L0
 import           Gibbon.Common
 import           Gibbon.DynFlags
-import           Gibbon.L0.Syntax                as L0
 
-import           Data.List                       as L
+import qualified Data.List                       as L
 import           Prelude                         as P
 
 import qualified Control.Applicative as L
@@ -200,179 +200,28 @@ desugarModule ::
   -> Module SrcSpanInfo
   -> String
   -> IO (PassM ProgBundle0)
-desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) mod_name = do
+desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) imported_name = do
   let type_syns = foldl collectTypeSynonyms M.empty decls
       funtys = foldr (collectTopTy type_syns) M.empty decls
   imported_progs :: [PassM ProgBundle0] <- 
-    mapM (processImport cfg pstate_ref (modname : import_route) dir) imports
+      mapM (processImport cfg pstate_ref (modname : import_route) dir) imports
   let prog = do
         imported_progs' <- mapM id imported_progs
         toplevels <- catMaybes <$> mapM (collectTopLevel type_syns funtys) decls
         let (defs,_vars,funs,inlines,main) = foldr classify init_acc toplevels
             funs' = foldr (\v acc -> M.update (\fn@(FunDef{funMeta}) -> Just (fn { funMeta = funMeta { funInline = Inline }})) v acc) funs inlines
-        imported_progs' <- mapM id imported_progs
-        let (defs0,funs0) =
-              foldr
-                (\Prog{ddefs,fundefs} (defs1,funs1) ->
-                     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 = foldr
-                                        (\d acc ->
-                                             if (ddefs M.! d) /= (defs1 M.! d)
-                                             then d : acc
-                                             else acc)
-                                        []
-                                        em1
-                         conflicts2 = 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)
-                (defs, funs')
-                imported_progs'
-        pure (Prog defs0 funs0 main)
-
-        let (defs, _vars, funs, inlines, main, optimizeDcons, userOrderings) =
-              foldr classify init_acc toplevels
-            userOrderings' = M.fromList $ coalese_constraints userOrderings
-            funs' =
-              foldr
-                (\v acc ->
-                   M.update
-                     (\fn@(FunDef {funMeta}) ->
-                        Just (fn {funMeta = funMeta {funInline = Inline}}))
-                     v
-                     acc)
-                funs
-                inlines
-            funs'' =
-              foldr
-                (\v acc ->
-                   M.update
-                     (\fn -> Just (addLayoutMetaData fn optimizeDcons))
-                     v
-                     acc)
-                funs'
-                (P.map fst (S.toList optimizeDcons))
-            funs''' =
-              foldr
-                (\k acc ->
-                   M.update
-                     (\fn@(FunDef {funName, funMeta}) ->
-                        Just
-                          (fn
-                             { funMeta =
-                                 funMeta
-                                   { userConstraintsDataCon =
-                                       M.lookup funName userOrderings'
-                                   }
-                             }))
-                     k
-                     acc)
-                funs''
-                (M.keys userOrderings')
-        imported_progs' <- mapM id imported_progs
-        let (defs0, funs0) =
-              foldr
-                (\Prog {ddefs, fundefs} (defs1, funs1) ->
-                   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 =
-                         foldr
-                           (\d acc ->
-                              if (ddefs M.! d) /= (defs1 M.! d)
-                                then d : acc
-                                else acc)
-                           []
-                           em1
-                       conflicts2 =
-                         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)
-                (defs, funs''')
-                imported_progs'
-        pure (Prog defs0 funs0 main) --dbgTraceIt (sdoc funs) dbgTraceIt "\n" dbgTraceIt (sdoc funs''') dbgTraceIt (sdoc userOrderings') dbgTraceIt "\n" dbgTraceIt (sdoc userOrderings)
+        let bundle = foldr mergeBundle [] imported_progs' 
+        pure $ ProgBundle bundle (ProgModule modname (Prog defs funs' main) imports)
   pure prog
   where
-    init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing, S.empty, [])
+    init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing)
     modname = moduleName head_mb
-    coalese_constraints ::
-         [(Var, M.Map DataCon [UserOrdering])]
-      -> [(Var, M.Map DataCon [UserOrdering])]
-    coalese_constraints constrs =
-      case constrs of
-        [] -> []
-        (var, map):xs ->
-          let same_func_constrs =
-                P.concatMap
-                  (\(a, b) ->
-                     if (var == a)
-                       then [(a, b)]
-                       else [])
-                  xs
-              maps_to_merge = P.concatMap (M.toList . snd) same_func_constrs
-              merged_maps = coalses_dconMap (maps_to_merge ++ M.toList map)
-              xs' = deleteMany same_func_constrs xs
-           in [(var, M.fromList merged_maps)] ++ (coalese_constraints xs')
-    coalses_dconMap ::
-         [(DataCon, [UserOrdering])] -> [(DataCon, [UserOrdering])]
-    coalses_dconMap dconOrdrs =
-      case dconOrdrs of
-        [] -> []
-        (dcon, orderings):xs ->
-          let same_dcons =
-                P.concatMap
-                  (\(a, b) ->
-                     if (dcon == a)
-                       then [(a, b)]
-                       else [])
-                  xs
-              same_orderings = (P.concatMap snd same_dcons) ++ orderings
-              xs' = deleteMany same_dcons xs
-           in [(dcon, same_orderings)] ++ coalses_dconMap xs'
-    deleteOne :: Eq x => (x, y) -> [(x, y)] -> [(x, y)]
-    deleteOne _ [] = [] -- Nothing to delete
-    deleteOne (a, b) ((c, d):ys)
-      | a == c = ys -- Drop exactly one matching item
-    deleteOne x (y:ys) = y : deleteOne x ys -- Drop one, but not this one (doesn't match).
-    deleteMany :: Eq x => [(x, y)] -> [(x, y)] -> [(x, y)]
-    deleteMany []     = id -- Nothing to delete
-    deleteMany (x:xs) = deleteMany xs . deleteOne x -- Delete one, then the rest.
     moduleName :: Maybe (ModuleHead a) -> String
-    moduleName Nothing = mod_name
+    moduleName Nothing = if imported_name == "Main" then imported_name
+                         else error "Imported module does not have a module declaration"
     moduleName (Just (ModuleHead _ mod_name1 _warnings _exports)) =
-      mnameToStr mod_name1
+      if imported_name == (mnameToStr mod_name1) || imported_name == "Main" then (mnameToStr mod_name1)
+      else error "Imported module does not match it's module declaration"
 
     classify thing (defs,vars,funs,inlines,main) =
       case thing of
@@ -382,9 +231,9 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
           case main of
             Nothing -> (defs, vars, funs, inlines, m)
             Just _  -> error $ "A module cannot have two main expressions."
-                               ++ show mod_name
+                               ++ show modname
         HInline v   -> (defs,vars,funs,S.insert v inlines,main)
-desugarModule _ _ _ _ m = error $ "desugarModule: " ++ prettyPrint m
+desugarModule _ _ _ _ m _ = error $ "desugarModule: " ++ prettyPrint m
 
 stdlibModules :: [String]
 stdlibModules =
@@ -405,7 +254,7 @@ processImport ::
   -> FilePath
   -> ImportDecl a
   -> IO (PassM ProgBundle0)
-processImport cfg pstate_ref import_route dir decl@ImportDecl {..}
+processImport cfg pstate_ref import_route dir ImportDecl {..}
     -- When compiling with Gibbon, we should *NOT* inline things defined in Gibbon.Prim.
   | mod_name == "Gibbon.Prim" = do
     (ParseState imported') <- readIORef pstate_ref

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

@@ -25,8 +25,6 @@ import qualified Data.Map as M
 
 import           Gibbon.Common as C
 import           Gibbon.Language hiding (UrTy(..))
-import           Language.Haskell.Exts.SrcLoc
-import           Language.Haskell.Exts          (ImportDecl)
 
 
 --------------------------------------------------------------------------------

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

@@ -14,17 +14,13 @@
 {-# LANGUAGE InstanceSigs #-}
 
 module Gibbon.Language.Syntax
-  (
     -- * Datatype definitions
   ( DDefs
   , DataCon
   , TyCon
   , Tag
   , IsBoxed
   , DDef(..)
-  , DataConMap
-  , UserOrdering(..)
-  , Constr(..)
   , lookupDDef
   , getConOrdering
   , getTyOfDataCon
@@ -43,7 +39,6 @@ module Gibbon.Language.Syntax
   , FunMeta(..)
   , FunRec(..)
   , FunInline(..)
-  , FunOptimizeLayout(..)
   , insertFD
   , fromListFD
   , initFunEnv
@@ -64,8 +59,6 @@ module Gibbon.Language.Syntax
   , lookupVEnv
   , extendFEnv
   , lookupFEnv
-  , unionEnv2
-  , unionEnv2s
   , lookupVEnv'
 
 -- * Expresssions and thier types
@@ -343,7 +336,7 @@ instance Out (ImportDecl SrcSpanInfo) where
     doc         = text . show
     docPrec n v = docPrec n (show v)
 instance (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, Generic (ArrowTy (TyOf ex))) => NFData (ProgModule ex) where
-  rnf (ProgModule name prog imports) = rnf prog
+  rnf (ProgModule _ prog _) = rnf prog
 
 deriving instance (Out (Prog ex)) => Out (ProgModule ex)
 deriving instance