diff --git a/gibbon-compiler/.gitignore b/gibbon-compiler/.gitignore index 02f2565fa..b30392163 100644 --- a/gibbon-compiler/.gitignore +++ b/gibbon-compiler/.gitignore @@ -32,3 +32,4 @@ demo/*.c demo/*.exe gibbon-compiler/examples/parallel/data/*.txt *.log.hs +*.log diff --git a/gibbon-compiler/examples/add1.hs b/gibbon-compiler/examples/add1.hs index b31d41695..d7bf4a5b7 100644 --- a/gibbon-compiler/examples/add1.hs +++ b/gibbon-compiler/examples/add1.hs @@ -1,9 +1,10 @@ +module Add where data Tree = Leaf Int | Node Tree Tree add1 :: Tree -> Tree add1 t = case t of Leaf x -> Leaf (x + 1) - Node x1 x2 -> Node (add1 x1) (add1 x2) + Node x1 x2 -> Node (Add.add1 x1) (Add.add1 x2) -main :: Tree -main = add1 (Node (Leaf 1) (Leaf 2)) +gibbon_main :: Tree +gibbon_main = Add.add1 (Node (Leaf 1) (Leaf 2)) diff --git a/gibbon-compiler/examples/imports/AddTree.hs b/gibbon-compiler/examples/imports/AddTree.hs new file mode 100644 index 000000000..9acdf78cc --- /dev/null +++ b/gibbon-compiler/examples/imports/AddTree.hs @@ -0,0 +1,8 @@ +module AddTree where + data Tree = Node Tree Tree | Leaf Int + + sum :: Tree -> Int + sum t = + case t of + Leaf v -> v + Node l r -> (sum l) + (sum r) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/Addone.hs b/gibbon-compiler/examples/imports/Addone.hs new file mode 100644 index 000000000..c073e31d9 --- /dev/null +++ b/gibbon-compiler/examples/imports/Addone.hs @@ -0,0 +1,15 @@ +module Addone where + import AddTree + + add :: Tree -> Tree + add t = case t of + Leaf x -> Leaf (x + 1) + Node x1 x2 -> Node (add x1) (add x2) + + sub :: Tree -> Tree + sub t = case t of + Leaf x -> Leaf (x - 1) + Node x1 x2 -> Node (sub x1) (sub x2) + + gibbon_main :: Tree + gibbon_main = add (Node (Leaf 1) (Leaf 2)) diff --git a/gibbon-compiler/examples/imports/Addtwo.hs b/gibbon-compiler/examples/imports/Addtwo.hs new file mode 100644 index 000000000..9b022b537 --- /dev/null +++ b/gibbon-compiler/examples/imports/Addtwo.hs @@ -0,0 +1,15 @@ +module Addtwo where + import AddTree + + add :: Tree -> Tree + add t = case t of + Leaf x -> Leaf (x + 2) + Node x1 x2 -> Node (add x1) (add x2) + + sub :: Tree -> Tree + sub t = case t of + Leaf x -> Leaf (x - 2) + Node x1 x2 -> Node (sub x1) (sub x2) + + gibbon_main :: Tree + gibbon_main = add (Node (Leaf 1) (Leaf 2)) diff --git a/gibbon-compiler/examples/imports/AllThreeImportModifications.ans b/gibbon-compiler/examples/imports/AllThreeImportModifications.ans new file mode 100644 index 000000000..f11c82a4c --- /dev/null +++ b/gibbon-compiler/examples/imports/AllThreeImportModifications.ans @@ -0,0 +1 @@ +9 \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/AllThreeImportModifications.hs b/gibbon-compiler/examples/imports/AllThreeImportModifications.hs new file mode 100644 index 000000000..472ad4f79 --- /dev/null +++ b/gibbon-compiler/examples/imports/AllThreeImportModifications.hs @@ -0,0 +1,6 @@ +module AllThreeImportModifications where + import qualified Addtwo as T (add) + import qualified Addone as O (add) + import AddTree as Tree (sum, Node, Leaf) + + gibbon_main = sum (T.add (O.add (Tree.Node (Tree.Leaf 1) (Tree.Leaf 2)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportAliased.ans b/gibbon-compiler/examples/imports/ImportAliased.ans new file mode 100644 index 000000000..f11c82a4c --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportAliased.ans @@ -0,0 +1 @@ +9 \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportAliased.hs b/gibbon-compiler/examples/imports/ImportAliased.hs new file mode 100644 index 000000000..e976a39b8 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportAliased.hs @@ -0,0 +1,6 @@ +module ImportAliased where + import qualified Addtwo as T + import qualified Addone as O + import AddTree as Tree + + gibbon_main = sum (T.add (O.add (Tree.Node (Tree.Leaf 1) (Tree.Leaf 2)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportQualified.ans b/gibbon-compiler/examples/imports/ImportQualified.ans new file mode 100644 index 000000000..f11c82a4c --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportQualified.ans @@ -0,0 +1 @@ +9 \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportQualified.hs b/gibbon-compiler/examples/imports/ImportQualified.hs new file mode 100644 index 000000000..7b1e36334 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportQualified.hs @@ -0,0 +1,6 @@ +module ImportQualified where + import qualified Addtwo + import qualified Addone + import AddTree + + gibbon_main = sum (Addtwo.add (Addone.add (Node (Leaf 1) (Leaf 2)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.ans b/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.ans new file mode 100644 index 000000000..7813681f5 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.ans @@ -0,0 +1 @@ +5 \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.hs b/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.hs new file mode 100644 index 000000000..61755a076 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportQualifiedAndSpecified.hs @@ -0,0 +1,6 @@ +module ImportQualifiedAndSpecified where + import qualified Addtwo (add) + import qualified Addone (sub) + import AddTree + + gibbon_main = sum (Addtwo.add (Addone.sub (Node (Leaf 1) (Leaf 2)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportSpecified.ans b/gibbon-compiler/examples/imports/ImportSpecified.ans new file mode 100644 index 000000000..7813681f5 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportSpecified.ans @@ -0,0 +1 @@ +5 \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/ImportSpecified.hs b/gibbon-compiler/examples/imports/ImportSpecified.hs new file mode 100644 index 000000000..735426c15 --- /dev/null +++ b/gibbon-compiler/examples/imports/ImportSpecified.hs @@ -0,0 +1,6 @@ +module ImportSpecified where + import Addtwo (add) + import Addone (sub) + import AddTree + + gibbon_main = sum (add (sub (Node (Leaf 1) (Leaf 2)))) \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/failing.md b/gibbon-compiler/examples/imports/failing.md new file mode 100644 index 000000000..cf4309c80 --- /dev/null +++ b/gibbon-compiler/examples/imports/failing.md @@ -0,0 +1,61 @@ +# Poly +### `/poly/Poly1.hs` + +Problem seems to be with the type names, numbers and Nothing, Cons, Nil, Right all match + +``` +< '#(10 #t 11 #f 2 4 (Poly1_Nothing_77_v_323) (Poly1_Right_76_v_342 20) (Poly1_Right_76_v_334 1) 12 #f 0 3 (Poly1_Cons_74_v_329 1 (Poly1_Cons_74_v_329 2 (Poly1_Nil_73_v_329))) (Poly1_Cons_74_v_329 1 (Poly1_Cons_74_v_329 2 (Poly1_Nil_73_v_329))) (Poly1_Right_76_v_334 1) (Poly1_Cons_74_v_329 11 (Poly1_Cons_74_v_329 12 (Poly1_Nil_73_v_329)))) +--- +> '#(10 #t 11 #f 2 4 (Nothing_v_295 ) (Right_v_315 20) (Right_v_306 1) 12 #f 0 3 (Cons_v_301 1(Cons_v_301 2(Nil_v_301 ))) (Cons_v_301 1(Cons_v_301 2(Nil_v_301 ))) (Right_v_306 1) (Cons_v_301 11(Cons_v_301 12(Nil_v_301 )))) +\ No newline at end of file +``` + +# Eval l/r +### `eval_l.hs` + +### `eval_r.hs` + +these are failing to properly import a module in interp mode this seems to stem from the fact the the imported file does not have a module declaration,,, so internally it renames with "Main" but the true Main module expects "Eval" b/c that's the name in the import statement. + +solving this by having the Main module tell each imported module how to name themselves ... this I think could get convoluted b/c a module decalred internally as A could be imported as B ... perhaps a subjective design decision but this seems to work + +# ArrowTy +### `layout1ContentSearch.hs` +``` +Couldn't match type 'ArrowTy [VectorTy (MetaTv $839)] + IntTy' with 'IntTy' + Expected type: IntTy + Actual type: ArrowTy [VectorTy (MetaTv $839)] IntTy + In the expression: + VarE "Gibbon_Vector_length_132" in Var "GenerateLayout1_mkBlogs_layout1_107" +``` + +This all seems to come from a similair pattern but it looks like the bug doesn't have anything to do with the error. The issue is scope: `Gibbon_Vector_length_132` is some global name but there is a `length` that is one of the function arguements. The rename pass matches length to the global function, causing the error. My solution was to force the global name to be qualified within the scope where `length` exists. So the global `Gibbon.Vector.length` can be accessed if qualified, but simple reference to `length` will use the function arguement `length` + +### `layout1ContentSearchRunPipeline.hs` + +### `layout1FilterBlogs.hs` + +### `layout1TagSearch.hs` + +### `layout2ContentSearch.hs` + +### `layout2FilterBlogs.hs` + +### `layout2TagSearch.hs` + +### `layout3ContentSearch.hs` + +### `layout3FilterBlogs.hs` + +### `layout3TagSearch.hs` + +### `layout4ContentSearch.hs` + +### `layout4FilterBlogs.hs` + +### `layout4TagSearch.hs` + +### `layout5ContentSearch.hs` + +### `layout5FilterBlogs.hs` \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/import_tests.md b/gibbon-compiler/examples/imports/import_tests.md new file mode 100644 index 000000000..c1e3ea8bd --- /dev/null +++ b/gibbon-compiler/examples/imports/import_tests.md @@ -0,0 +1,9 @@ +# Import Features +- no modifiers +- qualified +- specified +- aliased +- qualified & specified +- qualified & aliased +- specified & aliased +- qualified & specified & aliased \ No newline at end of file diff --git a/gibbon-compiler/examples/imports/Bar.hs b/gibbon-compiler/examples/imports/no-modifiers/Bar.hs similarity index 100% rename from gibbon-compiler/examples/imports/Bar.hs rename to gibbon-compiler/examples/imports/no-modifiers/Bar.hs diff --git a/gibbon-compiler/examples/imports/Baz.hs b/gibbon-compiler/examples/imports/no-modifiers/Baz.hs similarity index 100% rename from gibbon-compiler/examples/imports/Baz.hs rename to gibbon-compiler/examples/imports/no-modifiers/Baz.hs diff --git a/gibbon-compiler/examples/imports/Foo.ans b/gibbon-compiler/examples/imports/no-modifiers/Foo.ans similarity index 100% rename from gibbon-compiler/examples/imports/Foo.ans rename to gibbon-compiler/examples/imports/no-modifiers/Foo.ans diff --git a/gibbon-compiler/examples/imports/Foo.hs b/gibbon-compiler/examples/imports/no-modifiers/Foo.hs similarity index 100% rename from gibbon-compiler/examples/imports/Foo.hs rename to gibbon-compiler/examples/imports/no-modifiers/Foo.hs diff --git a/gibbon-compiler/examples/poly/Poly1.ans b/gibbon-compiler/examples/poly/Poly1.ans index 1ac14e9b9..e179b89d9 100644 --- a/gibbon-compiler/examples/poly/Poly1.ans +++ b/gibbon-compiler/examples/poly/Poly1.ans @@ -1 +1 @@ -'#(10 #t 11 #f 2 4 (Nothing_v_406) (Right_v_426 20) (Right_v_417 1) 12 #f 0 3 (Cons_v_412 1 (Cons_v_412 2 (Nil_v_412))) (Cons_v_412 1 (Cons_v_412 2 (Nil_v_412))) (Right_v_417 1) (Cons_v_412 11 (Cons_v_412 12 (Nil_v_412)))) +'#(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 f0808973d..7af4c5f73 100644 --- a/gibbon-compiler/examples/test_153.ans +++ b/gibbon-compiler/examples/test_153.ans @@ -1 +1 @@ -'#('#(2 3) (B_v_13 4 5)) +'#('#(2 3) (B5_v17 4 5)) diff --git a/gibbon-compiler/examples/test_164.ans b/gibbon-compiler/examples/test_164.ans index 6a191db12..6af50b27f 100644 --- a/gibbon-compiler/examples/test_164.ans +++ b/gibbon-compiler/examples/test_164.ans @@ -1 +1 @@ -(Cons_v_64 3 (Cons_v_64 5 (Cons_v_64 7 (Nil_v_64)))) +(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 a082d182f..fcb3ff9e2 100644 --- a/gibbon-compiler/examples/test_166.ans +++ b/gibbon-compiler/examples/test_166.ans @@ -1 +1 @@ -(Node_v_79 10 10 10 10 10 10 10 10 (Cell_v_79 5 5 5 5 5 5 5 5) (Cell_v_79 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/examples/test_191.ans b/gibbon-compiler/examples/test_191.ans index 1828a9fee..18f4f2b04 100644 --- a/gibbon-compiler/examples/test_191.ans +++ b/gibbon-compiler/examples/test_191.ans @@ -1 +1 @@ -(Cons 12 ->i (I 2) (Cons 12 ->i (I 1) (Nil)))'#() +(Cons26 12 ->i (I28 2) (Cons26 12 ->i (I28 1) (Nil27)))'#() \ No newline at end of file diff --git a/gibbon-compiler/examples/test_printpacked.ans b/gibbon-compiler/examples/test_printpacked.ans index 07209292f..55c61c8f0 100644 --- a/gibbon-compiler/examples/test_printpacked.ans +++ b/gibbon-compiler/examples/test_printpacked.ans @@ -1,4 +1,4 @@ -(Node (Node (Leaf 1)(Leaf 1))(Node (Leaf 1)(Leaf 1))) - ->i (Node (Node (Leaf 1)(Leaf 1))(Node (Leaf 1)(Leaf 1))) +(Node32 (Node32 (Leaf31 1)(Leaf31 1))(Node32 (Leaf31 1)(Leaf31 1))) + ->i (Node32 (Node32 (Leaf31 1)(Leaf31 1))(Node32 (Leaf31 1)(Leaf31 1))) 1 '#() \ No newline at end of file diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index a1b0c7196..9ea8bf5f3 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -28,6 +28,7 @@ flag LLVM_ENABLED library exposed-modules: Gibbon.Common Gibbon.Compiler + Gibbon.Bundler Gibbon.DynFlags Gibbon.Pretty Gibbon.SExpFrontend @@ -60,6 +61,7 @@ library Gibbon.NewL2.FromOldL2 -- compiler passes, roughly in the order they're run + Gibbon.Passes.FreshBundle Gibbon.Passes.Freshen Gibbon.Passes.Flatten Gibbon.Passes.InlineTriv diff --git a/gibbon-compiler/src/Gibbon/Bundler.hs b/gibbon-compiler/src/Gibbon/Bundler.hs new file mode 100644 index 000000000..2fdcf0276 --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Bundler.hs @@ -0,0 +1,54 @@ +-- | Union all the modules in a program bundle in to a single program +module Gibbon.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 + + + +-- | Main bundler, runs all imported modules through a union that combines +-- their function defintions and data definitions with main's +-- Names should be globally unique at this point +bundleModules :: ProgBundle0 -> PassM Prog0 +bundleModules bundle = do + let (ProgBundle modules main) = bundle + 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 + +-- | Bundle fold function +-- builds the full program by folding definitons and functions into the main +_bundleModule :: ProgModule0 -> (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 diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index c4dab877e..75c320f90 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -148,7 +148,7 @@ newUniq = state (\x -> (x, x+1)) -- | Generate a unique symbol by attaching a numeric suffix. gensym :: MonadState Int m => Var -> m Var -gensym v = state (\n -> (cleanFunName v `varAppend` "_" `varAppend` toVar (show n), n + 1)) +gensym v = state (\n -> (cleanFunName v `varAppend` toVar (show n), n + 1)) gensym_tag :: MonadState Int m => Var -> String -> m Var gensym_tag v str = state (\n -> (cleanFunName v `varAppend` toVar (show n ++ str) , n + 1)) @@ -356,10 +356,11 @@ abbrv n x = then str else L.take (n-3) str ++ "..." -lookup3 :: (Eq k, Show k, Show a, Show b) => k -> [(k,a,b)] -> (k,a,b) +lookup3 :: HasCallStack => (Eq k, Show k, Show a, Show b) => k -> [(k,a,b)] -> (k,a,b) lookup3 k ls = go ls where - go [] = error$ "lookup3: key "++show k++" not found in list:\n "++L.take 80 (show ls) + --go [] = error$ "lookup3: key "++show k++" not found in list:\n "++L.take 80 (show ls) + go [] = error$ "lookup3: key "++show k++" not found in list:\n "++ (show ls) go ((k1,a1,b1):r) | k1 == k = (k1,a1,b1) | otherwise = go r diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 6c2e8290d..0ef86335b 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -4,6 +4,9 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant return" #-} +{-# HLINT ignore "Redundant pure" #-} -- | The compiler pipeline, assembled from several passes. @@ -53,6 +56,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 @@ -60,6 +64,7 @@ import qualified Gibbon.L0.ElimNewtype as L0 import qualified Gibbon.L1.Typecheck as L1 import qualified Gibbon.L2.Typecheck as L2 import qualified Gibbon.L3.Typecheck as L3 +import Gibbon.Passes.FreshBundle (freshBundleNames) import Gibbon.Passes.Freshen (freshNames) import Gibbon.Passes.Flatten (flattenL1, flattenL2, flattenL3) import Gibbon.Passes.InlineTriv (inlineTriv) @@ -207,8 +212,11 @@ data CompileState a = CompileState , result :: Maybe (Value a) -- ^ Result of evaluating output of prior pass, if available. } +------------------------------------------------------------------------------- -- | Compiler entrypoint, given a full configuration and a list of -- files to process, do the thing. +-- +------------------------------------------------------------------------------- compile :: Config -> FilePath -> IO () compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do -- set the env var DEBUG, to verbosity, when > 1 @@ -217,34 +225,56 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do -- Use absolute path dir <- getCurrentDirectory let fp1 = dir fp0 - -- Parse the input file - ((l0, cnt0), fp) <- parseInput config input fp1 + -- Parse the input file & imports + -- get the bundle of modules + ((l0_bundle, cnt0), fp) <- parseInput config input fp1 let config' = config { srcFile = Just fp } - let initTypeChecked :: L0.Prog0 - initTypeChecked = - -- We typecheck first to turn the appropriate VarE's into FunRefE's. + ----------------------------------------------------------------------------- + -- do an early typecheck, before running through the passes or into the interpreter + -- perform the minimum transformations for a whole-progrm type-check (freshBundle, bundle, fresh, tc) + + ----------------------------------------------------------------------------- + let initTypeChecked' :: PassM L0.Prog0 + initTypeChecked' = do + bundle <- freshBundleNames l0_bundle + bundle' <- bundleModules bundle + bundle'' <- freshNames bundle' + bundle''' <- L0.tcProg bundle'' + pure bundle''' + let initTypeChecked = fst $ runPassM config 0 initTypeChecked' + {- fst $ runPassM defaultConfig cnt0 - (freshNames l0 >>= - (\fresh -> dbgTrace 5 ("\nFreshen:\n"++sepline++ "\n" ++pprender fresh) (L0.tcProg fresh))) + (freshBundleNames l0_bundle >>= + (\bundled -> dbgTrace 5 ("\nFreshen:\n" ++ sepline ++ "\n" ++ pprender bundled) + (L0.tcProg (fst $ runPassM defaultConfig 1 + (freshNames (fst $ runPassM defaultConfig 0 + (bundleModules bundled) + )) + )) + ) + ) + -} case mode of + -- run via the interpreter on the whole program Interp1 -> do - dbgTrace passChatterLvl ("\nParsed:\n"++sepline++ "\n" ++ sdoc l0) (pure ()) + dbgTrace passChatterLvl ("\nParsed:\n"++sepline++ "\n" ++ sdoc l0_bundle) (pure ()) dbgTrace passChatterLvl ("\nTypechecked:\n"++sepline++ "\n" ++ pprender initTypeChecked) (pure ()) runConf <- getRunConfig [] (_s1,val,_stdout) <- gInterpProg () runConf initTypeChecked print val + ToParse -> dbgPrintLn 0 $ pprender l0_bundle - ToParse -> dbgPrintLn 0 $ pprender l0 - + -- run via the passes _ -> do dbgPrintLn passChatterLvl $ " [compiler] pipeline starting, parsed program: "++ if dbgLvl >= passChatterLvl+1 - then "\n"++sepline ++ "\n" ++ sdoc l0 - else show (length (sdoc l0)) ++ " characters." + then "\n"++sepline ++ "\n" ++ sdoc l0_bundle + else show (length (sdoc l0_bundle)) ++ " characters." + -- (Stage 1) Run the program through the interpreter initResult <- withPrintInterpProg initTypeChecked @@ -253,7 +283,7 @@ compile config@Config{mode,input,verbosity,backend,cfile} fp0 = do let outfile = getOutfile backend fp cfile -- run the initial program through the compiler pipeline - let stM = passes config' l0 + let stM = passes config' l0_bundle l4 <- evalStateT stM (CompileState {cnt=cnt0, result=initResult}) case mode of @@ -321,34 +351,34 @@ setDebugEnvVar verbosity = hPutStrLn stderr$ " ! We set DEBUG based on command-line verbose arg: "++show l -parseInput :: Config -> Input -> FilePath -> IO ((L0.Prog0, Int), FilePath) +parseInput :: Config -> Input -> FilePath -> IO ((L0.ProgBundle0, Int), FilePath) parseInput cfg ip fp = do - (l0, f) <- - case ip of - Haskell -> (, fp) <$> HS.parseFile cfg fp - SExpr -> (, fp) <$> SExp.parseFile fp - Unspecified -> - case takeExtension fp of - ".hs" -> (, fp) <$> HS.parseFile cfg fp - ".sexp" -> (, fp) <$> SExp.parseFile fp - ".rkt" -> (, fp) <$> SExp.parseFile fp - ".gib" -> (, fp) <$> SExp.parseFile fp - oth -> do - -- A silly hack just out of sheer laziness vis-a-vis tab completion: - let f1 = fp ++ ".gib" - f2 = fp ++ "gib" - f1' <- doesFileExist f1 - f2' <- doesFileExist f2 - if (f1' && oth == "") || (f2' && oth == ".") - then (,f2) <$> SExp.parseFile f1 - else error $ mconcat - [ "compile: unrecognized file extension: " - , show oth - , " Please specify compile input format." - ] + --(l0, f) <- (, fp) <$> HS.parseFile cfg fp + (l0, f) <- case ip of + Haskell -> (, fp) <$> HS.parseFile cfg fp + SExpr -> (, fp) <$> SExp.parseFile fp + Unspecified -> + case takeExtension fp of + ".hs" -> (, fp) <$> HS.parseFile cfg fp + ".sexp" -> (, fp) <$> SExp.parseFile fp + ".rkt" -> (, fp) <$> SExp.parseFile fp + ".gib" -> (, fp) <$> SExp.parseFile fp + oth -> do + -- A silly hack just out of sheer laziness vis-a-vis tab completion: + let f1 = fp ++ ".gib" + f2 = fp ++ "gib" + f1' <- doesFileExist f1 + f2' <- doesFileExist f2 + if (f1' && oth == "") || (f2' && oth == ".") + then (,f2) <$> SExp.parseFile f1 + else error $ mconcat + [ "compile: unrecognized file extension: " + , show oth + , " Please specify compile input format." + ] let l0' = do parsed <- l0 -- dbgTraceIt (sdoc parsed) (pure ()) - HS.desugarLinearExts parsed + HS.desugarBundleLinearExts parsed (l0'', cnt) <- pure $ runPassM defaultConfig 0 l0' pure ((l0'', cnt), f) @@ -631,8 +661,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 -> 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 @@ -640,6 +670,14 @@ passes config@Config{dynflags} l0 = do parallel = gopt Opt_Parallel dynflags should_fuse = gopt Opt_Fusion dynflags tcProg3 = L3.tcProg isPacked + + -- generate unique names functions and data types + l0_bundle' <- go "freshBundle" freshBundleNames l0_bundle + + -- bundle modules + -- what does cnt do? -> the 0 in the following statement + let l0 = fst $ runPassM defaultConfig 0 (bundleModules l0_bundle') + l0 <- go "freshen" freshNames l0 l0 <- goE0 "typecheck" L0.tcProg l0 l0 <- go "elimNewtypes" L0.elimNewtypes l0 diff --git a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs index 8192da933..e98c90233 100644 --- a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs +++ b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs @@ -1,13 +1,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Use let" #-} module Gibbon.HaskellFrontend - ( parseFile, primMap, multiArgsToOne, desugarLinearExts ) where + ( parseFile + , primMap + , multiArgsToOne + , desugarBundleLinearExts + , desugarLinearExts + ) where 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 @@ -16,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 @@ -28,6 +36,13 @@ import Gibbon.L0.Syntax as L0 import Gibbon.Common import Gibbon.DynFlags +import qualified Data.List as L +import Prelude as P + +import qualified Control.Applicative as L +--import BenchRunner (main) + + -------------------------------------------------------------------------------- {- @@ -56,20 +71,21 @@ 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) parseFile cfg path = do - pstate0_ref <- newIORef emptyParseState - parseFile' cfg pstate0_ref [] path - + pstate0_ref <- newIORef emptyParseState + parseFile' cfg pstate0_ref [] path "Main" -data ParseState = ParseState - { imported :: M.Map (String, FilePath) Prog0 } +data ParseState = + ParseState + { imported :: M.Map (String, FilePath) ProgBundle0 + } emptyParseState :: ParseState emptyParseState = ParseState M.empty +-- should be a sperate recursive function that builds the dependency tree, and then another that parses the actual programs + parseMode :: ParseMode parseMode = defaultParseMode { extensions = [ EnableExtension ScopedTypeVariables , EnableExtension CPP @@ -78,16 +94,21 @@ parseMode = defaultParseMode { extensions = [ EnableExtension ScopedTypeVariable ++ (extensions defaultParseMode) } -parseFile' :: Config -> IORef ParseState -> [String] -> FilePath -> IO (PassM Prog0) -parseFile' cfg pstate_ref import_route path = do - when (gopt Opt_GhcTc (dynflags cfg)) $ - typecheckWithGhc cfg path +------------------------------------------------------------------------------- +-- parse a file, call desugar, and return the desugared bundle +-- will recurse down through import headers and fold the bundles together +------------------------------------------------------------------------------- +parseFile' :: + Config -> IORef ParseState -> [String] -> FilePath -> String -> IO (PassM ProgBundle0) +parseFile' cfg pstate_ref import_route path mod_name = do + when (gopt Opt_GhcTc (dynflags cfg)) $ typecheckWithGhc cfg path str <- readFile path let cleaned = removeLinearArrows str -- let parsed = parseModuleWithMode parseMode cleaned parsed <- parseFileContentsWithCommentsAndCPP defaultCpphsOptions parseMode cleaned case parsed of - ParseOk (hs,_comments) -> desugarModule cfg pstate_ref import_route (takeDirectory path) hs + ParseOk (hs, _comments) -> + desugarModule cfg pstate_ref import_route (takeDirectory path) hs mod_name ParseFailed loc er -> do error ("haskell-src-exts failed: " ++ er ++ ", at " ++ prettyPrint loc) @@ -157,59 +178,50 @@ data TopLevel type TopTyEnv = TyEnv TyScheme type TypeSynEnv = M.Map TyCon Ty0 -desugarModule :: (Show a, Pretty a) - => Config -> IORef ParseState -> [String] -> FilePath -> Module a -> IO (PassM Prog0) -desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) = do +-- | Merge a list of modules into a program bundle +mergeBundle :: ProgBundle0 -> [ProgModule0] -> [ProgModule0] +mergeBundle (ProgBundle x main) bundle = + foldr (\v acc -> if already_has v then acc else acc ++ [v]) bundle (x ++ [main]) + where + already_imported = L.map (\(ProgModule name _ _) -> name) bundle + already_has :: ProgModule0 -> Bool + already_has (ProgModule name _ _) = L.elem name already_imported + + +-- | 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 :: + Config + -> IORef ParseState + -> [String] + -> FilePath + -> Module SrcSpanInfo + -> String + -> IO (PassM ProgBundle0) +desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports decls) imported_name = do let type_syns = foldl collectTypeSynonyms M.empty decls - -- Since top-level functions and their types can't be declared in - -- single top-level declaration we first collect types and then collect - -- definitions. funtys = foldr (collectTopTy type_syns) M.empty decls - imported_progs :: [PassM Prog0] <- mapM (processImport cfg pstate_ref (mod_name : import_route) dir) imports + imported_progs :: [PassM ProgBundle0] <- + 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 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) - mod_name = moduleName head_mb - + modname = moduleName head_mb moduleName :: Maybe (ModuleHead a) -> String - moduleName Nothing = "Main" + 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 @@ -219,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 = @@ -234,36 +246,54 @@ stdlibModules = , "Gibbon.ByteString" ] -processImport :: Config -> IORef ParseState -> [String] -> FilePath -> ImportDecl a -> IO (PassM Prog0) -processImport cfg pstate_ref import_route dir decl@ImportDecl{..} +-- TIMMY - top level comment describing what this does +processImport :: + Config + -> IORef ParseState + -> [String] + -> FilePath + -> ImportDecl a + -> IO (PassM ProgBundle0) +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" = pure (pure (Prog M.empty M.empty Nothing)) - | otherwise = do + | mod_name == "Gibbon.Prim" = do + (ParseState imported') <- readIORef pstate_ref + case M.lookup (mod_name, "") imported' of + Just prog -> do pure $ pure prog + Nothing -> pure (pure (ProgBundle L.empty (ProgModule "Gibbon.Prim" (Prog M.empty M.empty Nothing) L.empty) )) + | otherwise = do when (mod_name `elem` import_route) $ - error $ "Circular dependency detected. Import path: "++ show (mod_name : import_route) - when (importQualified) $ error $ "Qualified imports not supported yet. Offending import: " ++ prettyPrint decl - when (isJust importAs) $ error $ "Module aliases not supported yet. Offending import: " ++ prettyPrint decl - when (isJust importSpecs) $ error $ "Selective imports not supported yet. Offending import: " ++ prettyPrint decl + error $ + "Circular dependency detected. Import path: " ++ + show (mod_name : import_route) + --when (isJust importAs) $ + -- error $ + -- "Module aliases not supported yet. Offending import: " ++ prettyPrint decl + --when (isJust importSpecs) $ + -- error $ + -- "Selective imports not supported yet. Offending import: " ++ + -- prettyPrint decl (ParseState imported) <- readIORef pstate_ref mod_fp <- if mod_name `elem` stdlibModules then stdlibImportPath mod_name else modImportPath importModule dir dbgTrace 5 ("Looking at " ++ mod_name) (pure ()) dbgTrace 5 ("Previously imported: " ++ show (M.keysSet imported)) (pure ()) - prog <- case M.lookup (mod_name, mod_fp) imported of - Just prog -> do - dbgTrace 5 ("Already imported " ++ mod_name) (pure ()) - pure prog - Nothing -> do - dbgTrace 5 ("Importing " ++ mod_name ++ " from " ++ mod_fp) (pure ()) - prog0 <- parseFile' cfg pstate_ref import_route mod_fp - (ParseState imported') <- readIORef pstate_ref - let (prog0',_) = defaultRunPassM prog0 - let imported'' = M.insert (mod_name, mod_fp) prog0' imported' - let pstate' = ParseState { imported = imported'' } - writeIORef pstate_ref pstate' - pure prog0' - + prog <- + case M.lookup (mod_name, mod_fp) imported of + Just prog -> do + dbgTrace 5 ("Already imported " ++ mod_name) (pure ()) + pure prog + Nothing -> do + dbgTrace 5 ("Importing " ++ mod_name ++ " from " ++ mod_fp) (pure ()) + -- parse import file + prog0 <- parseFile' cfg pstate_ref import_route mod_fp mod_name + (ParseState imported') <- readIORef pstate_ref + let (prog0', _) = defaultRunPassM prog0 + let imported'' = M.insert (mod_name, mod_fp) prog0' imported' + let pstate' = ParseState {imported = imported''} + writeIORef pstate_ref pstate' + pure prog0' pure (pure prog) where mod_name = mnameToStr importModule @@ -499,8 +529,10 @@ desugarExp type_syns toplevel e = -- | (qnameToStr f) == "error" -> pure $ PrimAppE (ErrorP (litToString lit Paren _ e2 -> desugarExp type_syns toplevel e2 H.Var _ qv -> do + -- where the expression name is parsed (for all expressions) let str = qnameToStr qv v = (toVar str) + -- v = (toVar ("timmy-" ++ str)) if str == "alloc_pdict" then do kty <- newMetaTy @@ -878,21 +910,31 @@ desugarExp type_syns toplevel e = _ -> error ("desugarExp: Unsupported expression: " ++ prettyPrint e) -desugarFun :: (Show a, Pretty a) => TypeSynEnv -> TopTyEnv -> TopTyEnv -> Decl a -> PassM (Var, [Var], TyScheme, Exp0) +-- parse function declarations +desugarFun :: + (Show a, Pretty a) + => TypeSynEnv + -> TopTyEnv + -> TopTyEnv + -> Decl a + -> PassM (Var, [Var], TyScheme, Exp0) desugarFun type_syns toplevel env decl = case decl of FunBind _ [Match _ fname pats (UnGuardedRhs _ bod) _where] -> do + -- where it sets the name ^^ could pass in module name here let fname_str = nameToStr fname fname_var = toVar (fname_str) (vars, arg_tys,bindss) <- unzip3 <$> mapM (desugarPatWithTy type_syns) pats let binds = concat bindss args = vars - fun_ty <- case M.lookup fname_var env of - Nothing -> do - ret_ty <- newMetaTy - let funty = ArrowTy arg_tys ret_ty - pure $ (ForAll [] funty) - Just ty -> pure ty + fun_ty <- + case M.lookup fname_var env of + Nothing -> do + ret_ty <- newMetaTy + let funty = ArrowTy arg_tys ret_ty + pure $ (ForAll [] funty) + Just ty -> pure ty + -- where it parses expressions \/\/ could parse module calls here bod' <- desugarExp type_syns toplevel bod pure $ (fname_var, args, unCurryTopTy fun_ty, (mkLets binds bod')) _ -> error $ "desugarFun: Found a function with multiple RHS, " ++ prettyPrint decl @@ -1276,24 +1318,30 @@ verifyBenchEAssumptions bench_allowed ex = not_allowed = verifyBenchEAssumptions False -------------------------------------------------------------------------------- - -desugarLinearExts :: Prog0 -> PassM Prog0 -desugarLinearExts (Prog ddefs fundefs main) = do - main' <- case main of - Nothing -> pure Nothing - Just (e,ty) -> do - let ty' = goty ty - e' <- go e - pure $ Just (e', ty') - fundefs' <- mapM (\fn -> do - bod <- go (funBody fn) - let (ForAll tyvars ty) = (funTy fn) - ty' = goty ty - pure $ fn { funBody = bod - , funTy = (ForAll tyvars ty') - }) - fundefs - pure (Prog ddefs fundefs' main') +desugarBundleLinearExts :: ProgBundle0 -> PassM ProgBundle0 +desugarBundleLinearExts (ProgBundle bundle main) = do + bundle' <- mapM desugarLinearExts bundle + main' <- desugarLinearExts main + pure $ ProgBundle bundle' main' + +desugarLinearExts :: ProgModule0 -> PassM ProgModule0 +desugarLinearExts (ProgModule name (Prog ddefs fundefs main) imports) = do + main' <- + case main of + Nothing -> pure Nothing + Just (e, ty) -> do + let ty' = goty ty + e' <- go e + pure $ Just (e', ty') + fundefs' <- + mapM + (\fn -> do + bod <- go (funBody fn) + let (ForAll tyvars ty) = (funTy fn) + ty' = goty ty + pure $ fn {funBody = bod, funTy = (ForAll tyvars ty')}) + fundefs + pure $ ProgModule name (Prog ddefs fundefs' main') imports where goty :: Ty0 -> Ty0 goty ty = diff --git a/gibbon-compiler/src/Gibbon/L0/Syntax.hs b/gibbon-compiler/src/Gibbon/L0/Syntax.hs index 80d91c322..e7848b663 100644 --- a/gibbon-compiler/src/Gibbon/L0/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L0/Syntax.hs @@ -26,6 +26,7 @@ import qualified Data.Map as M import Gibbon.Common as C import Gibbon.Language hiding (UrTy(..)) + -------------------------------------------------------------------------------- -- In L0, type information may be held in locations, as locations don't exist @@ -34,7 +35,13 @@ type DDefs0 = DDefs Ty0 type DDef0 = DDef Ty0 type FunDef0 = FunDef Exp0 type FunDefs0 = FunDefs Exp0 -type Prog0 = Prog Exp0 + +type Prog0 = Prog Exp0 + +------------------------------------------------------------------------------- + +type ProgModule0 = ProgModule Exp0 +type ProgBundle0 = ProgBundle Exp0 -------------------------------------------------------------------------------- diff --git a/gibbon-compiler/src/Gibbon/L0/Typecheck.hs b/gibbon-compiler/src/Gibbon/L0/Typecheck.hs index 947a9e54b..1b22eb7c8 100644 --- a/gibbon-compiler/src/Gibbon/L0/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L0/Typecheck.hs @@ -34,13 +34,24 @@ newtype TcM a = TcM (ExceptT Doc PassM a) instance MonadFail TcM where fail = error -runTcM :: TcM a -> PassM (Either Doc a) +runTcM :: TcM a -> PassM (Either Doc a) runTcM (TcM tc) = runExceptT tc -err :: Doc -> TcM a +err :: Doc -> TcM a err d = throwError ("L0.Typecheck: " $$ nest 4 d) -tcProg :: Prog0 -> PassM Prog0 +tcProgBundle :: ProgBundle0 -> PassM ProgBundle0 +tcProgBundle (ProgBundle bundle main) = do + bundle' <- mapM tcProgModule bundle + main' <- tcProgModule main + pure $ ProgBundle bundle' main' + +tcProgModule :: ProgModule0 -> PassM ProgModule0 +tcProgModule (ProgModule modname prog imports) = do + prog' <- tcProg prog + pure $ ProgModule modname prog' imports + +tcProg :: Prog0 -> PassM Prog0 tcProg prg@Prog{ddefs,fundefs,mainExp} = do let init_fenv = M.map funTy fundefs fundefs_tc <- mapM (tcFun ddefs init_fenv) fundefs @@ -68,7 +79,7 @@ tcProg prg@Prog{ddefs,fundefs,mainExp} = do pure prg { fundefs = fundefs' , mainExp = mainExp' } -tcFun :: DDefs0 -> Gamma -> FunDef0 -> PassM FunDef0 +tcFun :: DDefs0 -> Gamma -> FunDef0 -> PassM FunDef0 tcFun ddefs fenv fn@FunDef{funArgs,funTy,funBody, funName} = do res <- runTcM $ do let (ForAll tyvars (ArrowTy gvn_arg_tys gvn_retty)) = funTy @@ -83,7 +94,7 @@ tcFun ddefs fenv fn@FunDef{funArgs,funTy,funBody, funName} = do Left er -> error $ render er ++ " in " ++ show funName Right fn1 -> pure fn1 -tcExps :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] +tcExps :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] -> [(Bool, Exp0)] -> TcM (Subst, [Ty0], [Exp0]) tcExps ddefs sbst venv fenv bound_tyvars ls = do (sbsts,tys,exps) <- unzip3 <$> mapM go ls @@ -92,7 +103,7 @@ tcExps ddefs sbst venv fenv bound_tyvars ls = do go (is_main, e) = tcExp ddefs sbst venv fenv bound_tyvars is_main e -- -tcExp :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] +tcExp :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] -> Bool -> Exp0 -> TcM (Subst, Ty0, Exp0) tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> case ex of @@ -139,7 +150,7 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> PrimAppE pr args -> do (s1, arg_tys, args_tc) <- tcExps ddefs sbst venv fenv bound_tyvars (zip (repeat is_main) args) let arg_tys' = map (zonkTy s1) arg_tys - checkLen :: Int -> TcM () + checkLen :: Int -> TcM () checkLen n = if length args == n then pure () @@ -637,7 +648,7 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> pure (a', args', c) ) (dataCons ddf) else pure [x] - ) brs :: TcM [(DataCon, [(Var, Ty0)], Exp0)] + ) brs :: TcM [(DataCon, [(Var, Ty0)], Exp0)] let tycons_brs = map (getTyOfDataCon ddefs . fst3) brs' case L.nub tycons_brs of [one] -> if one == tycon @@ -753,7 +764,7 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> exp_doc = "In the expression: " <+> doc ex -tcCases :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] +tcCases :: DDefs0 -> Subst -> Gamma -> Gamma -> [TyVar] -> DDef0 -> [(DataCon, [(Var, Ty0)], Exp0)] -> Bool -> Exp0 -> TcM (Subst, Ty0, [(DataCon, [(Var, Ty0)], Exp0)]) tcCases ddefs sbst venv fenv bound_tyvars ddf brs is_main ex = do @@ -779,20 +790,20 @@ tcCases ddefs sbst venv fenv bound_tyvars ddf brs is_main ex = do pure (s3, head tys',exps) where -- pairs [1,2,3,4,5] = [(1,2), (2,3) (4,5)] - pairs :: [a] -> [(a,a)] + pairs :: [a] -> [(a,a)] pairs [] = [] pairs [_] = [] pairs (x:y:xs) = (x,y) : pairs (y:xs) -- | Instantiate the topmost for-alls of the argument type with meta -- type variables. -instantiate :: TyScheme -> TcM ([Ty0], Ty0) +instantiate :: TyScheme -> TcM ([Ty0], Ty0) instantiate (ForAll tvs ty) = do tvs' <- mapM (const newMetaTy) tvs let ty' = substTyVar (M.fromList $ zip tvs tvs') ty pure (tvs', ty') -generalize :: Gamma -> Subst -> [TyVar] -> Ty0 -> TcM (Subst, TyScheme) +generalize :: Gamma -> Subst -> [TyVar] -> Ty0 -> TcM (Subst, TyScheme) generalize env s bound_tyvars ty = do new_bndrs <- mapM (\(Meta i) -> do @@ -809,11 +820,11 @@ generalize env s bound_tyvars ty = do env_tvs = metaTvsInTySchemes (M.elems env) res_tvs = metaTvsInTy ty - meta_tvs :: [MetaTv] + meta_tvs :: [MetaTv] meta_tvs = res_tvs L.\\ env_tvs -- -instDataConTy :: DDefs0 -> DataCon -> TcM ([Ty0], [Ty0], Ty0) +instDataConTy :: DDefs0 -> DataCon -> TcM ([Ty0], [Ty0], Ty0) instDataConTy ddefs dcon = do let tycon = getTyOfDataCon ddefs dcon ddf = lookupDDef ddefs tycon @@ -861,7 +872,7 @@ newtype Subst = Subst (M.Map MetaTv Ty0) instance Semigroup Subst where -- (Subst s1) <> (Subst s2) = -- let mp = M.map (zonkTy (Subst s1)) s2 `M.union` s1 in Subst mp - (<>) :: Subst -> Subst -> Subst + (<>) :: Subst -> Subst -> Subst (Subst s1) <> (Subst s2) = let s2' = M.map (zonkTy (Subst s1)) s2 mp = M.unionWith combine s2' s1 @@ -870,7 +881,7 @@ instance Semigroup Subst where -- | Combine substitutions. In case of substitutions with intersecting keys, -- we will take the narrower type of the two. e.g. combine [($1, $2)] [($1, IntTy)] -- should be [($1, IntTy)]. Map.union does a left biased union so it will result in [($1, $2)] -combine :: Ty0 -> Ty0 -> Ty0 +combine :: Ty0 -> Ty0 -> Ty0 combine v1 v2 | v1 == v2 = v1 | otherwise = case (v1, v2) of (MetaTv _, _) -> v2 @@ -881,7 +892,7 @@ combine v1 v2 | v1 == v2 = v1 (PackedTy a1 v1s, PackedTy a2 v2s) -> if a1 == a2 then PackedTy a1 (zipWith combine v1s v2s) else error $ "PackedTy doesn't match "++ sdoc v1 ++ " with " ++ sdoc v2 - _ -> error $ "Failed to combine = " ++ sdoc v1 ++ " with " ++ sdoc v2 + _ -> error $ "Failed to combine = " ++ sdoc (show v1) ++ " with " ++ sdoc (show v2) emptySubst :: Subst @@ -918,11 +929,11 @@ zonkTy s@(Subst mp) ty = zonkTyScheme :: Subst -> TyScheme -> TyScheme zonkTyScheme s (ForAll tvs ty) = ForAll tvs (zonkTy s ty) -zonkTyEnv :: Subst -> Gamma -> Gamma +zonkTyEnv :: Subst -> Gamma -> Gamma zonkTyEnv s env = M.map (zonkTyScheme s) env -- Apply a substitution to an expression i.e substitue all types in it. -zonkExp :: Subst -> Exp0 -> Exp0 +zonkExp :: Subst -> Exp0 -> Exp0 zonkExp s ex = case ex of VarE{} -> ex @@ -999,7 +1010,7 @@ zonkExp s ex = go = zonkExp s -- Substitute tyvars with types in a ddef. -substTyVarDDef :: DDef0 -> [Ty0] -> TcM DDef0 +substTyVarDDef :: DDef0 -> [Ty0] -> TcM DDef0 substTyVarDDef d@DDef{tyArgs,dataCons} tys = if length tyArgs /= length tys then err $ text "substTyVarDDef: tyArgs don't match the tyapps, in " @@ -1017,7 +1028,7 @@ substTyVarDDef d@DDef{tyArgs,dataCons} tys = , dataCons = dcons' } -- Substitue all tyvars in an expression. -substTyVarExp :: M.Map TyVar Ty0 -> Exp0 -> Exp0 +substTyVarExp :: M.Map TyVar Ty0 -> Exp0 -> Exp0 substTyVarExp s ex = case ex of VarE{} -> ex @@ -1064,7 +1075,7 @@ substTyVarExp s ex = where go = substTyVarExp s -substTyVarPrim :: M.Map TyVar Ty0 -> Prim Ty0 -> Prim Ty0 +substTyVarPrim :: M.Map TyVar Ty0 -> Prim Ty0 -> Prim Ty0 substTyVarPrim mp pr = case pr of VAllocP elty -> VAllocP (substTyVar mp elty) @@ -1095,7 +1106,7 @@ substTyVarPrim mp pr = _ -> pr -tyVarToMetaTyl :: [Ty0] -> TcM (M.Map TyVar Ty0, [Ty0]) +tyVarToMetaTyl :: [Ty0] -> TcM (M.Map TyVar Ty0, [Ty0]) tyVarToMetaTyl tys = foldlM (\(env', acc) ty -> do @@ -1106,7 +1117,7 @@ tyVarToMetaTyl tys = -- | Replace the specified quantified type variables by -- given meta type variables. -tyVarToMetaTy :: Ty0 -> TcM (M.Map TyVar Ty0, Ty0) +tyVarToMetaTy :: Ty0 -> TcM (M.Map TyVar Ty0, Ty0) tyVarToMetaTy = go M.empty where go :: M.Map TyVar Ty0 -> Ty0 -> TcM (M.Map TyVar Ty0, Ty0) @@ -1153,7 +1164,7 @@ tyVarToMetaTy = go M.empty -- Unification -------------------------------------------------------------------------------- -unify :: Exp0 -> Ty0 -> Ty0 -> TcM Subst +unify :: Exp0 -> Ty0 -> Ty0 -> TcM Subst unify ex ty1 ty2 | ty1 == ty2 = --dbgTraceIt (sdoc ty1 ++ "/" ++ sdoc ty2) $ pure emptySubst @@ -1192,7 +1203,7 @@ unify ex ty1 ty2 $$ nest 2 (doc ex) -unifyl :: Exp0 -> [Ty0] -> [Ty0] -> TcM Subst +unifyl :: Exp0 -> [Ty0] -> [Ty0] -> TcM Subst unifyl _ [] [] = pure emptySubst unifyl e (a:as) (b:bs) = do -- N.B. We must apply s1 over the rest of the list before unifying it, i.e. @@ -1207,7 +1218,7 @@ unifyl e as bs = err $ text "Couldn't unify:" <+> doc as <+> text "and" <+> doc $$ text "In the expression: " $$ nest 2 (doc e) -unifyVar :: Exp0 -> MetaTv -> Ty0 -> TcM Subst +unifyVar :: Exp0 -> MetaTv -> Ty0 -> TcM Subst unifyVar ex a t | occursCheck a t = err $ text "Occurs check: cannot construct the inifinite type: " $$ nest 2 (doc a <+> text " ~ " <+> doc t) @@ -1216,14 +1227,14 @@ unifyVar ex a t | otherwise = pure $ Subst (M.singleton a t) -occursCheck :: MetaTv -> Ty0 -> Bool +occursCheck :: MetaTv -> Ty0 -> Bool occursCheck a t = a `elem` metaTvsInTy t -------------------------------------------------------------------------------- -- Other helpers -------------------------------------------------------------------------------- -ensureEqualTy :: Exp0 -> Ty0 -> Ty0 -> TcM () +ensureEqualTy :: Exp0 -> Ty0 -> Ty0 -> TcM () ensureEqualTy ex ty1 ty2 | ty1 == ty2 = pure () | otherwise = err $ text "Couldn't match expected type:" <+> doc ty1 diff --git a/gibbon-compiler/src/Gibbon/L1/Interp.hs b/gibbon-compiler/src/Gibbon/L1/Interp.hs index bad9dae4f..b9d45b8ec 100644 --- a/gibbon-compiler/src/Gibbon/L1/Interp.hs +++ b/gibbon-compiler/src/Gibbon/L1/Interp.hs @@ -297,6 +297,9 @@ applyPrim rc p args = (PrintSym, [VInt n]) -> do tell $ string8 (show n) pure $ VProd [] + (PrintChar, [c]) -> do + tell $ string8 (show c) + pure $ VProd [] oth -> error $ "unhandled prim or wrong number of arguments: "++show oth where diff --git a/gibbon-compiler/src/Gibbon/Language/Syntax.hs b/gibbon-compiler/src/Gibbon/Language/Syntax.hs index 040055886..d08688fe0 100644 --- a/gibbon-compiler/src/Gibbon/Language/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/Language/Syntax.hs @@ -10,44 +10,100 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE InstanceSigs #-} module Gibbon.Language.Syntax - ( -- * Datatype definitions - DDefs, DataCon, TyCon, Tag, IsBoxed, DDef(..) - , lookupDDef, getConOrdering, getTyOfDataCon, lookupDataCon, lkp - , lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef - - -- * Function definitions - , FunctionTy(..), FunDefs, FunDef(..), FunMeta(..), FunRec(..), FunInline(..) - , insertFD, fromListFD, initFunEnv - - -- * Programs - , Prog(..), progToEnv, getFunTy - - -- * Environments - , TyEnv, Env2(..), emptyEnv2 - , extendVEnv, extendsVEnv, lookupVEnv, extendFEnv, lookupFEnv - - -- * Expresssions and thier types - , PreExp(..), Prim(..), UrTy(..) - - -- * Functors for recursion-schemes - , PreExpF(..), PrimF(..), UrTyF(..) - - -- * Generic operations - , FreeVars(..), Expression(..), Binds, Flattenable(..) - , Simplifiable(..), SimplifiableExt(..), Typeable(..) - , Substitutable(..), SubstitutableExt(..), Renamable(..) - - -- * Helpers for writing instances - , HasSimplifiable, HasSimplifiableExt, HasSubstitutable, HasSubstitutableExt - , HasRenamable, HasOut, HasShow, HasEq, HasGeneric, HasNFData - - , -- * Interpreter - Interp(..), InterpExt(..), InterpProg(..), Value(..), ValEnv, InterpLog, - InterpM, runInterpM, execAndPrint - + ( DDefs + , DataCon + , TyCon + , Tag + , IsBoxed + , DDef(..) + , lookupDDef + , getConOrdering + , getTyOfDataCon + , lookupDataCon + , lkp + , lookupDataCon' + , insertDD + , emptyDD + , fromListDD + , isVoidDDef + +-- * Function definitions + , FunctionTy(..) + , FunDefs + , FunDef(..) + , FunMeta(..) + , FunRec(..) + , FunInline(..) + , insertFD + , fromListFD + , initFunEnv + +-- * Programs + , Prog(..) + , ProgModule(..) + , ProgBundle(..) + , progToEnv + , getFunTy + +-- * Environments + , TyEnv + , Env2(..) + , emptyEnv2 + , extendVEnv + , extendsVEnv + , lookupVEnv + , extendFEnv + , lookupFEnv + , lookupVEnv' + +-- * Expresssions and thier types + , PreExp(..) + , Prim(..) + , UrTy(..) + +-- * Functors for recursion-schemes + , PreExpF(..) + , PrimF(..) + , UrTyF(..) + +-- * Generic operations + , FreeVars(..) + , Expression(..) + , Binds + , Flattenable(..) + , Simplifiable(..) + , SimplifiableExt(..) + , Typeable(..) + , Substitutable(..) + , SubstitutableExt(..) + , Renamable(..) + +-- * Helpers for writing instances + , HasSimplifiable + , HasSimplifiableExt + , HasSubstitutable + , HasSubstitutableExt + , HasRenamable + , HasOut + , HasShow + , HasEq + , HasGeneric + , HasNFData + -- * Interpreter + , Interp(..) + , InterpExt(..) + , InterpProg(..) + , Value(..) + , ValEnv + , InterpLog + , InterpM + , runInterpM + , execAndPrint ) where import Control.DeepSeq @@ -63,12 +119,16 @@ import qualified Data.Set as S import Data.Word ( Word8 ) import Data.Kind ( Type ) import Text.PrettyPrint.GenericPretty +import Text.PrettyPrint (text) + import Data.Functor.Foldable.TH import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Builder (Builder) import System.IO.Unsafe (unsafePerformIO) import Gibbon.Common +import Language.Haskell.Exts (ImportDecl, SrcSpanInfo) + -------------------------------------------------------------------------------- -- Data type definitions @@ -241,6 +301,8 @@ data Prog ex = Prog { ddefs :: DDefs (TyOf ex) , mainExp :: Maybe (ex, (TyOf ex)) } +------------------------------------------------------------------------------- + -- Since 'FunDef' is defined using a type family, we cannot use the deriving clause. -- Ryan Scott recommended using singletons-like alternative outlined here: -- https://lpaste.net/365181 @@ -250,7 +312,46 @@ deriving instance (Show (TyOf ex), Show ex, Show (ArrowTy (TyOf ex))) => Show (P deriving instance (Eq (TyOf ex), Eq ex, Eq (ArrowTy (TyOf ex))) => Eq (Prog ex) deriving instance (Ord (TyOf ex), Ord ex, Ord (ArrowTy (TyOf ex))) => Ord (Prog ex) deriving instance Generic (Prog ex) -deriving instance (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, Generic (ArrowTy (TyOf ex))) => NFData (Prog ex) + +deriving instance + (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, + Generic (ArrowTy (TyOf ex))) => + NFData (Prog 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 = ProgModule String (Prog ex) [ImportDecl SrcSpanInfo] +data ProgBundle ex = ProgBundle [ProgModule ex] (ProgModule ex) + +deriving instance + (Show (TyOf ex), Show ex, Show (ArrowTy (TyOf ex))) => + Show (ProgModule ex) +deriving instance Generic (ProgModule ex) +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 _ prog _) = rnf prog + +deriving instance (Out (Prog ex)) => Out (ProgModule ex) +deriving instance + (Show (TyOf ex), Show ex, Show (ArrowTy (TyOf ex))) => + Show (ProgBundle ex) + +deriving instance + (NFData (TyOf ex), NFData (ArrowTy (TyOf ex)), NFData ex, + Generic (ArrowTy (TyOf ex))) => + NFData (ProgBundle ex) + +deriving instance Generic (ProgBundle ex) +deriving instance (Out (ProgModule ex)) => Out (ProgBundle ex) + + -- | Abstract some of the differences of top level program types, by -- having a common way to extract an initial environment. The diff --git a/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs b/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs new file mode 100644 index 000000000..bd9f05293 --- /dev/null +++ b/gibbon-compiler/src/Gibbon/Passes/FreshBundle.hs @@ -0,0 +1,368 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Fuse foldr/map" #-} + + -- | Create unique names for functions and data types across all modules + -- replace all references with their unique counters parts + -- includes parsing import headers and resolving imported names +module Gibbon.Passes.FreshBundle (freshBundleNames) where +import qualified Data.Map as M +import qualified Data.List as L +import Gibbon.Common +import Gibbon.L0.Syntax +import Language.Haskell.Exts (Name, ImportDecl (ImportDecl), SrcSpanInfo, ImportSpec (..), CName, ModuleName (ModuleName)) +import Language.Haskell.Exts.Syntax (CName(..)) +import Language.Haskell.Exts (Name(..)) +import Language.Haskell.Exts (ImportSpecList(..)) +import GHC.Stack (HasCallStack) + +type VarEnv = M.Map Var Var + + + -- | Go through all the modules and create a global environment of uniques + -- run through each of the modules again and replace references with their unique counterparts, including imported references +freshBundleNames :: ProgBundle0 -> PassM ProgBundle0 +freshBundleNames bundle = do + -- build global map of uniques + -- {legal reference} => unique + (uniquedefenv, uniquefunenv, uniqueconstenv) <- buildGlobalEnv bundle + + let ProgBundle modules main = bundle + -- run through modules, fresh names + modules' <- mapM (\v -> freshModule v bundle uniquedefenv uniquefunenv uniqueconstenv) modules + main' <- freshModule main bundle uniquedefenv uniquefunenv uniqueconstenv + -- update keys + modules'' <- mapM (\v -> freshModuleKeys v uniquedefenv uniquefunenv) modules' + main'' <- freshModuleKeys main' uniquedefenv uniquefunenv + pure $ ProgBundle modules'' main'' + +-- helper functions ----------------------------------------------------------- + +-- | Update the function and data type keys in each module +freshModuleKeys :: ProgModule0 -> VarEnv -> VarEnv -> PassM ProgModule0 +freshModuleKeys (ProgModule name (Prog defs funs main) imports) uniquedefenv uniquefunenv = do + let funs' = M.mapKeys (\k -> findFreshedName (varAppend (toVar (name ++ ".")) k) uniquefunenv) funs + let defs' = M.mapKeys (\k -> findFreshedName (varAppend (toVar (name ++ ".")) k) uniquedefenv) defs + pure $ ProgModule name (Prog defs' funs' main) imports + +-- | Find the imported module from the import header +findImportedModule :: ImportDecl SrcSpanInfo -> M.Map String ProgModule0 -> ProgModule0 +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)) + +-- | Transform all references to their unique counterparts +freshModule :: ProgModule0 -> ProgBundle0 -> VarEnv -> VarEnv -> VarEnv -> PassM ProgModule0 +freshModule (ProgModule modname (Prog defs funs main) imports) (ProgBundle bundle _) uniquedefenv uniquefunenv uniqueconstrenv = + do + defs' <- traverse (\v -> freshDDef v defenv'' constrenv'') defs + funs' <- traverse (\v -> freshFun v defenv'' funenv'' constrenv'') funs + main' <- case main of + Nothing -> return Nothing + Just (m,ty) -> do m' <- findFreshInExp m defenv'' funenv'' constrenv'' + return $ Just (m',ty) + return $ ProgModule modname (Prog defs' funs' main') imports + where + modname' = toVar (modname ++ ".") + constrs = L.map (\(constrName, _) -> toVar constrName) + (foldr (\(DDef _ _ dataCons) acc -> acc ++ dataCons) [] (M.elems defs)) + -- add qualified and unqualified names to the env + modmap = M.fromList $ L.zip (L.map (\(ProgModule m _ _) -> m) bundle) bundle + funenv = foldr (\f acc -> M.insert (varAppend modname' f) (findFreshedName (varAppend modname' f) uniquefunenv) acc) M.empty (M.keys funs) + defenv = foldr (\d acc -> M.insert (varAppend modname' d) (findFreshedName (varAppend modname' d) uniquedefenv) acc) M.empty (M.keys defs) + constrenv = foldr(\c acc -> M.insert (varAppend modname' c) (findFreshedName (varAppend modname' c) uniqueconstrenv) acc) M.empty constrs + funenv' = foldr (\f acc -> M.insert f (findFreshedName (varAppend modname' f) uniquefunenv) acc) funenv (M.keys funs) + defenv' = foldr (\d acc -> M.insert d (findFreshedName (varAppend modname' d) uniquedefenv) acc) defenv (M.keys defs) + constrenv' = foldr (\c acc -> M.insert c (findFreshedName (varAppend modname' c) uniqueconstrenv) acc) constrenv constrs + (defenv'', funenv'', constrenv'') = + foldr (\(d, f, c) (dacc, facc, cacc) -> (M.union d dacc, M.union f facc, M.union c cacc)) (defenv', funenv', constrenv') + $ map (\i -> getImportedEnv (findImportedModule i modmap) i uniquedefenv uniquefunenv uniqueconstrenv) imports + +-- | Transform references in data definitions to uniques +freshDDef :: HasCallStack => DDef Ty0 -> VarEnv -> VarEnv -> PassM (DDef Ty0) +freshDDef DDef{tyName,tyArgs,dataCons} defenv constrenv = do + let dataCons' = L.map (\(dataCon, vs) -> (fromVar (findFreshedName (toVar dataCon) constrenv), vs)) dataCons + let dataCons'' = L.map (\v -> findFreshInDataCons v defenv) dataCons' + let tyName' = findFreshedName tyName defenv + pure $ DDef tyName' tyArgs dataCons'' + +-- | Transform references in function definitions to uniques +freshFun :: FunDef Exp0 -> VarEnv -> VarEnv -> VarEnv -> PassM (FunDef Exp0) +freshFun (FunDef nam nargs funty bod meta) defenv funenv constrenv = + do + let nam' = findFreshedName nam funenv + funty' <- findFreshInTyScheme funty defenv + let funenv' = foldr (\v acc -> M.insert v v acc ) funenv nargs + bod' <- findFreshInExp bod defenv funenv' constrenv + pure $ FunDef nam' nargs funty' bod' meta + +findFreshInTyScheme :: TyScheme -> VarEnv -> PassM TyScheme +findFreshInTyScheme (ForAll tvs ty) defenv = do + pure $ ForAll tvs $ findFreshInTy ty defenv + +findFreshInTy :: Ty0 -> VarEnv -> Ty0 +findFreshInTy ty defenv = + case ty of + IntTy -> ty + CharTy -> ty + FloatTy -> ty + SymTy0 -> ty + BoolTy -> ty + ArenaTy -> ty + SymSetTy -> ty + SymHashTy -> ty + MetaTv{} -> 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 + let k' = findFreshInTy k defenv + let v' = findFreshInTy v defenv + PDictTy k' v' + ArrowTy tys t -> do + let tys' = L.map (\v -> findFreshInTy v defenv) tys + let t' = findFreshInTy t defenv + ArrowTy tys' t' + PackedTy tycon tys -> PackedTy (fromVar (findFreshedName (toVar tycon) defenv)) $ L.map (\v -> findFreshInTy v defenv) tys + VectorTy el_t -> VectorTy $ findFreshInTy el_t defenv + ListTy el_t -> ListTy $ findFreshInTy el_t defenv + IntHashTy -> ty + +findFreshInDataCons :: (DataCon, [(IsBoxed, Ty0)]) -> VarEnv -> (DataCon, [(IsBoxed, Ty0)]) +findFreshInDataCons (con, tys) defenv = + do + let tys' = L.map (\(boxed, ty) -> (boxed, (findFreshInTy ty defenv))) tys + (con, tys') + +-- | Find unique names in expressions +findFreshInExp :: Exp0 -> VarEnv -> VarEnv -> VarEnv -> PassM Exp0 +findFreshInExp expr defenv funenv constrenv = + case expr of + LitE i -> return $ LitE i + CharE c -> return $ CharE c + FloatE i -> return $ FloatE i + LitSymE v -> return $ LitSymE v + --VarE v -> return $ VarE (varAppend (toVar "seen-") v) + VarE v -> return $ VarE (tryToFindFreshedName v funenv) + + AppE v locs ls -> do + let v' = findFreshedName v funenv + ls' <- traverse (\e -> findFreshInExp e defenv funenv constrenv) ls + return $ AppE v' locs ls' + + PrimAppE p es -> do + es' <- traverse (\v -> findFreshInExp v defenv funenv constrenv) es + return $ PrimAppE p es' + + LetE (v,_locs,ty, e1) e2 -> do + let ty' = findFreshInTy ty defenv + let funenv' = M.insert v v funenv + e1' <- findFreshInExp e1 defenv funenv' constrenv + e2' <- findFreshInExp e2 defenv funenv' constrenv + return $ LetE (v, [], ty', e1') e2' + + IfE e1 e2 e3 -> do + e1' <- findFreshInExp e1 defenv funenv constrenv + e2' <- findFreshInExp e2 defenv funenv constrenv + e3' <- findFreshInExp e3 defenv funenv constrenv + return $ IfE e1' e2' e3' + + ProjE i e -> do + e' <- findFreshInExp e defenv funenv constrenv + return $ ProjE i e' + + MkProdE es -> do + es' <- traverse (\v -> findFreshInExp v defenv funenv constrenv) es + return $ MkProdE es' + + CaseE e mp -> do + e' <- findFreshInExp e defenv funenv constrenv + mp' <- mapM (\(c,prs,ae) -> do + let c' = case c of + "_default" -> c + _ -> (fromVar (findFreshedName (toVar c) constrenv)) + ae' <- findFreshInExp ae defenv funenv constrenv + return (c', prs, ae')) mp + return $ CaseE e' mp' + + DataConE loc c es -> do + let c' = (fromVar (findFreshedName (toVar c) constrenv)) + es' <- traverse (\v -> findFreshInExp v defenv funenv constrenv) es + return $ DataConE loc c' es' + + TimeIt e t b -> do + e' <- findFreshInExp e defenv funenv constrenv + return $ TimeIt e' t b + WithArenaE v e -> do + e' <- findFreshInExp e defenv funenv constrenv + return $ WithArenaE v e' + SpawnE v locs ls -> do + ls' <- traverse (\e -> findFreshInExp e defenv funenv constrenv) ls + return $ SpawnE v locs ls' + SyncE -> return $ SyncE + MapE (v, d, ve) e -> do + e' <- findFreshInExp e defenv funenv constrenv + ve' <- findFreshInExp ve defenv funenv constrenv + return $ MapE (v, d, ve') e' + FoldE (v1, d1, e1) (v2, d2, e2) e3 -> do + e1' <- findFreshInExp e1 defenv funenv constrenv + e2' <- findFreshInExp e2 defenv funenv constrenv + e3' <- findFreshInExp e3 defenv funenv constrenv + return $ FoldE (v1, d1, e1') (v2, d2, e2') e3' + Ext ext -> case ext of + LambdaE args bod -> do + bod' <- findFreshInExp bod defenv funenv constrenv + return $ Ext $ LambdaE args bod' + PolyAppE a b -> do + return $ Ext $ PolyAppE a b + FunRefE tyapps f -> do + return $ Ext $ FunRefE tyapps f + BenchE fn tyapps args b -> do + args' <- mapM (\arg -> findFreshInExp arg defenv funenv constrenv) args + return $ Ext $ BenchE fn tyapps args' b + ParE0 ls -> do + ls' <- mapM (\l -> findFreshInExp l defenv funenv constrenv) ls + return $ Ext $ ParE0 ls' + PrintPacked ty arg -> do + let ty' = findFreshInTy ty defenv + arg' <- findFreshInExp arg defenv funenv constrenv + return $ Ext $ PrintPacked ty' arg' + CopyPacked ty arg -> do + let ty' = findFreshInTy ty defenv + arg' <- findFreshInExp arg defenv funenv constrenv + return $ Ext $ CopyPacked ty' arg' + TravPacked ty arg -> do + let ty' = findFreshInTy ty defenv + arg' <- findFreshInExp arg defenv funenv constrenv + return $ Ext $ TravPacked ty' arg' + L p e -> do + e' <- findFreshInExp e defenv funenv constrenv + return $ Ext $ L p e' + LinearExt a -> do + return $ Ext $ LinearExt a + +-- | Parse import header and map references to unique names +getImportedEnv :: ProgModule0 -> ImportDecl SrcSpanInfo -> VarEnv -> VarEnv -> VarEnv -> (VarEnv, VarEnv, VarEnv) +getImportedEnv (ProgModule _ (Prog defs funs _) _) imp uniquedefenv uniquefunenv uniqueconstrenv = do + let ImportDecl _ (ModuleName _ impname) qual _ _ _ as specs = imp + let impname' = toVar (impname ++ ".") + let qualname = case as of + Just (ModuleName _ n) -> toVar $ n ++ "." + Nothing -> toVar $ impname ++ "." + let constrs = L.map (\(constrName, _) -> toVar constrName) + (foldr (\(DDef _ _ dataCons) acc -> acc ++ dataCons) [] (M.elems defs)) + let impenv :: (VarEnv, VarEnv, VarEnv) + impenv = case specs of + Just (ImportSpecList _ _ speclist) -> do + let specednames = foldr (\v acc -> (parseSpec v) ++ acc) [] speclist + let funs' = foldr (\k acc -> case M.lookup (varAppend impname' k) uniquefunenv of + Nothing -> acc + Just found -> do + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty specednames + let defs' = foldr (\k acc -> case M.lookup (varAppend impname' k) uniquedefenv of + Nothing -> acc + Just found -> do + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty specednames + let constrs' = foldr (\k acc -> case M.lookup (varAppend impname' k) uniqueconstrenv of + Nothing -> acc + Just found -> do + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty specednames + (defs', funs', constrs') + Nothing -> do + let funs' = foldr (\k acc -> do + let found = findFreshedName (varAppend impname' k) uniquefunenv + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty (M.keys funs) + let defs' = foldr (\k acc -> do + let found = findFreshedName (varAppend impname' k) uniquedefenv + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty (M.keys defs) + let constrs' = foldr (\k acc -> case M.lookup (varAppend impname' k) uniqueconstrenv of + Nothing -> acc + Just found -> do + let acc' = M.insert (varAppend qualname k) found acc + if qual then acc' + else M.insert k found acc' + ) M.empty constrs + (defs', funs', constrs') + impenv + +-- simple helper functions to convert `Name`s and `CNames`s to Vars +name2var :: Name SrcSpanInfo -> Var +name2var name = case name of + Ident _ str -> toVar str + Symbol _ str -> toVar str +cname2var :: CName SrcSpanInfo -> Var +cname2var name = case name of + 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 _ nm -> [name2var nm] + -- a class, datatype, or type + IAbs _ _ nm -> [name2var nm] + -- a class with all it's methods, or a datatype with all it's constructors + IThingAll _ nm -> [name2var nm] + -- a class with some of it's methods, or a datatype with some of it's constructors + IThingWith _ nm thgs -> [name2var nm] ++ map cname2var thgs + + +-- construct global registry of uniques +-- returns Map {qualified name} => {globally unique name} +buildGlobalEnv :: ProgBundle0 -> PassM (VarEnv, VarEnv, VarEnv) +buildGlobalEnv (ProgBundle modules main) = do + (ddefenv, fdefenv, constrenv) <- _buildGlobalEnv main -- generate uniques in main module + names <- mapM _buildGlobalEnv modules -- generate uniques in imported modules + pure $ foldr (\(ddefs, fdefs, constrs) (dacc, facc, cacc) -> (M.union ddefs dacc, M.union fdefs facc, M.union constrs cacc)) (ddefenv, fdefenv, constrenv) names -- union + +-- generate map of qualified names to uniques for a module +_buildGlobalEnv :: ProgModule0 -> PassM (VarEnv, VarEnv, VarEnv) +_buildGlobalEnv (ProgModule modname (Prog ddefs fdefs _) _) = + do + freshfdefs <- mapM gensym fdefs' -- generate uniques + freshddefs <- mapM gensym ddefs' + freshconstrs <- mapM gensym constrs' + let fdefenv = M.fromList $ zip (L.map (\v -> varAppend modname' v) fdefs') freshfdefs -- map qualified names to uniques + let ddefenv = M.fromList $ zip (L.map (\v -> varAppend modname' v) ddefs') freshddefs + let constrenv = M.fromList $ zip (L.map (\v -> varAppend modname' v) constrs') freshconstrs + pure (ddefenv, fdefenv, constrenv) + where + modname' = toVar (modname ++ ".") + constrs = L.map (\(constrName, _) -> toVar constrName) + (foldr (\(DDef _ _ dataCons) acc -> acc ++ dataCons) [] (M.elems ddefs)) + fdefs' = M.keys fdefs -- create qualified names + ddefs' = M.keys ddefs + constrs' = constrs + +-- helper functions +-- try to find the name, but don't cry if you can't,,, used for VarEs +tryToFindFreshedName :: Var -> VarEnv -> Var +tryToFindFreshedName name e = + do case M.lookup name e of + Just freshname -> freshname + Nothing -> name + +-- map a legal reference to a unique name +findFreshedName :: HasCallStack => Var -> VarEnv -> Var +findFreshedName name e = + case M.lookup name e of + Just freshname -> freshname + Nothing -> error $ "could not find name: " ++ (fromVar name) ++ "\n in env: " ++ (show e) diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 44defae28..3dec0360e 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE InstanceSigs #-} module Gibbon.Pretty ( Pretty(..), PPStyle(..), HasPretty, render, pprintHsWithEnv, pprender ) where @@ -66,6 +67,28 @@ instance HasPretty ex => Pretty (Prog ex) where PPInternal -> ddefsDoc $+$ funsDoc $+$ meDoc PPHaskell -> ghc_compat_prefix False $+$ ddefsDoc $+$ funsDoc $+$ meDoc $+$ ghc_compat_suffix False +instance HasPretty ex => Pretty (ProgModule ex) where + pprintWithStyle sty (ProgModule _ prog _) = + let (Prog ddefs funs me) = prog + meDoc = case me of + Nothing -> empty + -- Uh, we need versions of hasBenchE for L0, L2 and L3 too : + -- Assume False for now. + Just (e,ty) -> renderMain False (pprintWithStyle sty e) (pprintWithStyle sty ty) + ddefsDoc = vcat $ map (pprintWithStyle sty) $ M.elems ddefs + funsDoc = vcat $ map (pprintWithStyle sty) $ M.elems funs + in case sty of + PPInternal -> ddefsDoc $+$ funsDoc $+$ meDoc + PPHaskell -> ghc_compat_prefix False $+$ ddefsDoc $+$ funsDoc $+$ meDoc $+$ ghc_compat_suffix False + +instance HasPretty ex => Pretty (ProgBundle ex) where + pprintWithStyle sty (ProgBundle bundle main) = + let mainDoc = pprintWithStyle sty main + bundleDoc = vcat $ map (pprintWithStyle sty) $ bundle + in case sty of + PPInternal -> mainDoc $+$ bundleDoc + PPHaskell -> ghc_compat_prefix False $+$ mainDoc $+$ bundleDoc $+$ ghc_compat_suffix False + renderMain :: Bool -> Doc -> Doc -> Doc renderMain has_bench m ty = if has_bench diff --git a/gibbon-compiler/src/Gibbon/SExpFrontend.hs b/gibbon-compiler/src/Gibbon/SExpFrontend.hs index e9c42cdd1..205286b44 100644 --- a/gibbon-compiler/src/Gibbon/SExpFrontend.hs +++ b/gibbon-compiler/src/Gibbon/SExpFrontend.hs @@ -184,10 +184,11 @@ tagDataCons ddefs = go allCons -- | Convert from raw, unstructured S-Expression into the L1 program datatype we expect. -parseSExp :: [Sexp] -> PassM Prog0 +parseSExp :: [Sexp] -> PassM ProgBundle0 parseSExp ses = do prog@Prog {ddefs} <- go ses [] [] [] Nothing - mapMExprs (tagDataCons ddefs) prog + prog' <- mapMExprs (tagDataCons ddefs) prog + pure $ ProgBundle [] (ProgModule "Main" prog' []) where -- WARNING: top-level constant definitions are INLINED everywhere. @@ -723,7 +724,7 @@ handleRequire baseFile (l:ls) = return $ l:ls' -- ^ Parse a file to an L1 program. Return also the gensym counter. -parseFile :: FilePath -> IO (PassM Prog0) +parseFile :: FilePath -> IO (PassM ProgBundle0) parseFile file = do txt <- fmap bracketHacks $ -- fmap stripHashLang $ diff --git a/gibbon-compiler/tests/test-gibbon-examples.yaml b/gibbon-compiler/tests/test-gibbon-examples.yaml index 87c578122..9189cb633 100644 --- a/gibbon-compiler/tests/test-gibbon-examples.yaml +++ b/gibbon-compiler/tests/test-gibbon-examples.yaml @@ -330,9 +330,25 @@ tests: - name: Tuples.hs answer-file: examples/Tuples.hs.ans - - name: Foo.hs + - name: AllThreeImportModifications.hs dir: examples/imports/ - answer-file: examples/imports/Foo.ans + answer-file: examples/imports/AllThreeImportModifications.ans + + - name: ImportQualifiedAndSpecified.hs + dir: examples/imports/ + answer-file: examples/imports/ImportQualifiedAndSpecified.ans + + - name: ImportAliased.hs + dir: examples/imports/ + answer-file: examples/imports/ImportAliased.ans + + - name: ImportQualified.hs + dir: examples/imports/ + answer-file: examples/imports/ImportQualified.ans + + - name: ImportSpecified.hs + dir: examples/imports/ + answer-file: examples/imports/ImportSpecified.ans - name: NeedsClosure.hs dir: examples/poly