From ecac58906cf0e3daa61cb98bc030cdaf2846d93b Mon Sep 17 00:00:00 2001 From: timmy Date: Fri, 8 Mar 2024 11:54:09 -0500 Subject: [PATCH] merged in main --- gibbon-compiler/examples/poly/Poly1.ans | 2 +- gibbon-compiler/examples/test_153.ans | 2 +- gibbon-compiler/examples/test_164.ans | 2 +- gibbon-compiler/examples/test_166.ans | 2 +- gibbon-compiler/src/Gibbon/Bundler.hs | 2 +- gibbon-compiler/src/Gibbon/HaskellFrontend.hs | 183 ++---------------- gibbon-compiler/src/Gibbon/L0/Syntax.hs | 2 - gibbon-compiler/src/Gibbon/Language/Syntax.hs | 9 +- .../src/Gibbon/Passes/FreshBundle.hs | 30 +-- gibbon-compiler/src/Gibbon/Pretty.hs | 2 +- 10 files changed, 38 insertions(+), 198 deletions(-) diff --git a/gibbon-compiler/examples/poly/Poly1.ans b/gibbon-compiler/examples/poly/Poly1.ans index 49fb2c17..e179b89d 100644 --- a/gibbon-compiler/examples/poly/Poly1.ans +++ b/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)))) \ No newline at end of file +'#(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)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/test_153.ans b/gibbon-compiler/examples/test_153.ans index 3bbd24cf..7af4c5f7 100644 --- a/gibbon-compiler/examples/test_153.ans +++ b/gibbon-compiler/examples/test_153.ans @@ -1 +1 @@ -'#((A6_v15 2 3) (B5_v16 4 5)) \ No newline at end of file +'#('#(2 3) (B5_v17 4 5)) diff --git a/gibbon-compiler/examples/test_164.ans b/gibbon-compiler/examples/test_164.ans index 31fcf772..6af50b27 100644 --- a/gibbon-compiler/examples/test_164.ans +++ b/gibbon-compiler/examples/test_164.ans @@ -1 +1 @@ -(Cons19_v50 3 (Cons19_v50 5 (Cons19_v50 7 (Nil18_v50)))) \ No newline at end of file +(Cons19_v68 3 (Cons19_v68 5 (Cons19_v68 7 (Nil18_v68)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/test_166.ans b/gibbon-compiler/examples/test_166.ans index 663746e8..fcb3ff9e 100644 --- a/gibbon-compiler/examples/test_166.ans +++ b/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)) \ No newline at end of file diff --git a/gibbon-compiler/src/Gibbon/Bundler.hs b/gibbon-compiler/src/Gibbon/Bundler.hs index 0b2bf056..2fdcf027 100644 --- a/gibbon-compiler/src/Gibbon/Bundler.hs +++ b/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 diff --git a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs index 229946e1..e98c9023 100644 --- a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs +++ b/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 diff --git a/gibbon-compiler/src/Gibbon/L0/Syntax.hs b/gibbon-compiler/src/Gibbon/L0/Syntax.hs index 837c34c4..e7848b66 100644 --- a/gibbon-compiler/src/Gibbon/L0/Syntax.hs +++ b/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) -------------------------------------------------------------------------------- diff --git a/gibbon-compiler/src/Gibbon/Language/Syntax.hs b/gibbon-compiler/src/Gibbon/Language/Syntax.hs index 8cac7d5f..d08688fe 100644 --- a/gibbon-compiler/src/Gibbon/Language/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/Language/Syntax.hs @@ -14,7 +14,6 @@ {-# LANGUAGE InstanceSigs #-} module Gibbon.Language.Syntax - ( -- * Datatype definitions ( DDefs , DataCon @@ -22,9 +21,6 @@ module Gibbon.Language.Syntax , 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 diff --git a/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs b/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs index 5564e567..bd9f0529 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs @@ -46,8 +46,8 @@ freshModuleKeys (ProgModule name (Prog defs funs main) imports) uniquedefenv uni -- | Find the imported module from the import header findImportedModule :: ImportDecl SrcSpanInfo -> M.Map String ProgModule0 -> ProgModule0 -findImportedModule mod modmap = do - let (ImportDecl _ (ModuleName _ name) _ _ _ _ _ _) = mod +findImportedModule modl modmap = do + let (ImportDecl _ (ModuleName _ name) _ _ _ _ _ _) = modl case M.lookup name modmap of Just found -> found Nothing -> error $ "Could not find module " ++ name ++ " in imported modules: " ++ (show (M.keys modmap)) @@ -113,7 +113,7 @@ findFreshInTy ty defenv = SymSetTy -> ty SymHashTy -> ty MetaTv{} -> ty - TyVar tv -> ty + TyVar _ -> ty ProdTy tys -> ProdTy $ L.map (\v -> findFreshInTy v defenv) tys SymDictTy v t -> SymDictTy v $ findFreshInTy t defenv PDictTy k v -> do @@ -137,8 +137,8 @@ findFreshInDataCons (con, tys) defenv = -- | Find unique names in expressions findFreshInExp :: Exp0 -> VarEnv -> VarEnv -> VarEnv -> PassM Exp0 -findFreshInExp exp defenv funenv constrenv = - case exp of +findFreshInExp expr defenv funenv constrenv = + case expr of LitE i -> return $ LitE i CharE c -> return $ CharE c FloatE i -> return $ FloatE i @@ -148,7 +148,7 @@ findFreshInExp exp defenv funenv constrenv = AppE v locs ls -> do let v' = findFreshedName v funenv - ls' <- traverse (\v -> findFreshInExp v defenv funenv constrenv) ls + ls' <- traverse (\e -> findFreshInExp e defenv funenv constrenv) ls return $ AppE v' locs ls' PrimAppE p es -> do @@ -198,7 +198,7 @@ findFreshInExp exp defenv funenv constrenv = e' <- findFreshInExp e defenv funenv constrenv return $ WithArenaE v e' SpawnE v locs ls -> do - ls' <- traverse (\v -> findFreshInExp v defenv funenv constrenv) ls + ls' <- traverse (\e -> findFreshInExp e defenv funenv constrenv) ls return $ SpawnE v locs ls' SyncE -> return $ SyncE MapE (v, d, ve) e -> do @@ -304,25 +304,25 @@ getImportedEnv (ProgModule _ (Prog defs funs _) _) imp uniquedefenv uniquefunenv -- simple helper functions to convert `Name`s and `CNames`s to Vars name2var :: Name SrcSpanInfo -> Var name2var name = case name of - Ident l str -> toVar str - Symbol l str -> toVar str + Ident _ str -> toVar str + Symbol _ str -> toVar str cname2var :: CName SrcSpanInfo -> Var cname2var name = case name of - VarName l str -> name2var str - ConName l str -> name2var str + VarName _ str -> name2var str + ConName _ str -> name2var str -- parse the import header speclist parseSpec :: ImportSpec SrcSpanInfo -> [Var] parseSpec imp = case imp of -- imported a variable - IVar l nm -> [name2var nm] + IVar _ nm -> [name2var nm] -- a class, datatype, or type - IAbs l nmspc nm -> [name2var nm] + IAbs _ _ nm -> [name2var nm] -- a class with all it's methods, or a datatype with all it's constructors - IThingAll l nm -> [name2var nm] + IThingAll _ nm -> [name2var nm] -- a class with some of it's methods, or a datatype with some of it's constructors - IThingWith l nm thgs -> [name2var nm] ++ map cname2var thgs + IThingWith _ nm thgs -> [name2var nm] ++ map cname2var thgs -- construct global registry of uniques diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 1fe45039..3dec0360 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -68,7 +68,7 @@ instance HasPretty ex => Pretty (Prog ex) where PPHaskell -> ghc_compat_prefix False $+$ ddefsDoc $+$ funsDoc $+$ meDoc $+$ ghc_compat_suffix False instance HasPretty ex => Pretty (ProgModule ex) where - pprintWithStyle sty (ProgModule name prog imports) = + pprintWithStyle sty (ProgModule _ prog _) = let (Prog ddefs funs me) = prog meDoc = case me of Nothing -> empty