diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index fa0c021b2..046d265a8 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -8,14 +8,21 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.19.20250531 +# version: 0.19.20250917 # -# REGENDATA ("0.19.20250531",["github","cabal.project","--config=cabal.haskell-ci"]) +# REGENDATA ("0.19.20250917",["github","cabal.project","--config=cabal.haskell-ci"]) # name: Haskell-CI on: - - push - - pull_request + push: + branches: + - main + pull_request: + branches: + - main + merge_group: + branches: + - main jobs: linux: name: Haskell-CI - Linux - ${{ matrix.compiler }} @@ -86,8 +93,8 @@ jobs: chmod a+x "$HOME/.ghcup/bin/ghcup" - name: Install cabal-install run: | - "$HOME/.ghcup/bin/ghcup" install cabal 3.14.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV" - name: Install GHC (GHCup) if: matrix.setup-method == 'ghcup' run: | @@ -163,7 +170,7 @@ jobs: chmod a+x $HOME/.cabal/bin/cabal-plan cabal-plan --version - name: checkout - uses: actions/checkout@v4 + uses: actions/checkout@v5 with: path: source - name: initial cabal.project for sdist @@ -188,7 +195,11 @@ jobs: touch cabal.project.local echo "packages: ${PKGDIR_gibbon}" >> cabal.project echo "package gibbon" >> cabal.project - echo " ghc-options: -Werror=missing-methods" >> cabal.project + echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project + if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package gibbon" >> cabal.project ; fi + if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi + if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package gibbon" >> cabal.project ; fi + if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi cat >> cabal.project <> cabal.project.local diff --git a/.gitignore b/.gitignore index 4c8f15ecf..470f1b47a 100644 --- a/.gitignore +++ b/.gitignore @@ -45,4 +45,5 @@ cabal.project.local~ .HTF/ .ghc.environment.* stack*.yaml.lock -.vscode/* \ No newline at end of file +.vscode/* +racket-* diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 8a652ca47..e9efe829b 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -2,3 +2,4 @@ no-tests-no-benchmarks: False unconstrained: False cabal-check: False haddock: False +branches: main diff --git a/gibbon-compiler/gibbon.cabal b/gibbon-compiler/gibbon.cabal index bfea8dec2..574451930 100644 --- a/gibbon-compiler/gibbon.cabal +++ b/gibbon-compiler/gibbon.cabal @@ -128,8 +128,6 @@ library , language-c-quote >= 0.12.1 && < 1 , mainland-pretty >= 0.6.1 && < 1 , safe - , uuid - , hashable >= 1.4.5.0 -- Brings in lots of ekmett dependencies: -- , either @@ -156,8 +154,6 @@ executable gibbon main-is: Frontend.hs build-depends: base - , haskell-src-exts - , filepath , gibbon default-language: Haskell2010 @@ -197,12 +193,12 @@ test-suite test-gibbon executable test-gibbon-examples hs-source-dirs: tests main-is: BenchRunner.hs - build-depends: gibbon, - base, containers, mtl, transformers, + build-depends: base, containers, process, filepath, directory, time, clock, text, bytestring, yaml, optparse-applicative, scientific, prettyprinter, prettyprinter-ansi-terminal + build-tool-depends: gibbon:gibbon default-language: Haskell2010 other-modules: TestRunner diff --git a/gibbon-compiler/src/Gibbon/Compiler.hs b/gibbon-compiler/src/Gibbon/Compiler.hs index 0be937ca1..de13b0341 100644 --- a/gibbon-compiler/src/Gibbon/Compiler.hs +++ b/gibbon-compiler/src/Gibbon/Compiler.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} diff --git a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs index bf381067d..af1659b80 100644 --- a/gibbon-compiler/src/Gibbon/HaskellFrontend.hs +++ b/gibbon-compiler/src/Gibbon/HaskellFrontend.hs @@ -8,12 +8,10 @@ module Gibbon.HaskellFrontend import Control.Monad import Data.Foldable ( foldrM ) -#if !MIN_VERSION_base(4,21,0) -import Data.Foldable ( foldl' ) -#endif import Data.Maybe (catMaybes, isJust) import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.List as L import qualified Safe as Sf import Data.IORef @@ -1411,7 +1409,7 @@ desugarLinearExts (Prog ddefs fundefs main) = do case fn' of Ext (LambdaE [(v,ProdTy tys)] bod) -> do let ty = Sf.headErr tys - bod'' = foldl' (\acc i -> gSubstE (ProjE i (VarE v)) (VarE v) acc) bod [0..(length tys)] + bod'' = L.foldl' (\acc i -> gSubstE (ProjE i (VarE v)) (VarE v) acc) bod [0..(length tys)] pure (LetE (v,[],ty,e) bod'') _ -> error $ "desugarLinearExts: couldn't desugar " ++ sdoc ex ReverseAppE fn arg -> do diff --git a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs index 103dd9b7c..7580e246d 100644 --- a/gibbon-compiler/src/Gibbon/L0/Specialize2.hs +++ b/gibbon-compiler/src/Gibbon/L0/Specialize2.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} diff --git a/gibbon-compiler/src/Gibbon/L0/Syntax.hs b/gibbon-compiler/src/Gibbon/L0/Syntax.hs index bcadfa133..0b85076c9 100644 --- a/gibbon-compiler/src/Gibbon/L0/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L0/Syntax.hs @@ -506,8 +506,9 @@ recoverType ddfs env2 ex = CharE _ -> CharTy FloatE{} -> FloatTy LitSymE _ -> IntTy - AppE v tyapps _ -> let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v - in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + AppE v tyapps _ -> case fEnv env2 # v of + (ForAll tyvars (ArrowTy _ retty)) -> substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + ty -> error $ "Function applied with type arguments has an unexpected type. Got " ++ sdoc ty ++ " in function " ++ sdoc v -- PrimAppE (DictInsertP ty) ((L _ (VarE v)):_) -> SymDictTy (Just v) ty -- PrimAppE (DictEmptyP ty) ((L _ (VarE v)):_) -> SymDictTy (Just v) ty PrimAppE p _ -> primRetTy1 p @@ -525,8 +526,9 @@ recoverType ddfs env2 ex = oth -> error$ "typeExp: Cannot project fields from this type: "++show oth ++"\nExpression:\n "++ sdoc ex ++"\nEnvironment:\n "++sdoc (vEnv env2) - SpawnE v tyapps _ -> let (ForAll tyvars (ArrowTy _ retty)) = fEnv env2 # v - in substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + SpawnE v tyapps _ -> case fEnv env2 # v of + (ForAll tyvars (ArrowTy _ retty)) -> substTyVar (M.fromList (fragileZip tyvars tyapps)) retty + ty -> error $ "Spawned function has an unexpected type. Got " ++ sdoc ty ++ " in function " ++ sdoc v SyncE -> voidTy0 CaseE _ mp -> let (c,args,e) = Sf.headErr mp diff --git a/gibbon-compiler/src/Gibbon/L0/Typecheck.hs b/gibbon-compiler/src/Gibbon/L0/Typecheck.hs index 380a16267..9d9a63c8c 100644 --- a/gibbon-compiler/src/Gibbon/L0/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L0/Typecheck.hs @@ -73,14 +73,15 @@ tcProg prg@Prog{ddefs,fundefs,mainExp} = do 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 - init_venv = M.fromList $ zip funArgs $ map (ForAll []) gvn_arg_tys - init_s = emptySubst - (s1, drvd_funBody_ty, funBody_tc) <- - tcExp ddefs init_s init_venv fenv tyvars False funBody - s2 <- unify funBody drvd_funBody_ty gvn_retty - pure $ fn { funTy = zonkTyScheme (s1 <> s2) funTy - , funBody = zonkExp (s1 <> s2) funBody_tc } + case funTy of + (ForAll tyvars (ArrowTy gvn_arg_tys gvn_retty)) -> do + let init_venv = M.fromList $ zip funArgs $ map (ForAll []) gvn_arg_tys + init_s = emptySubst + (s1, drvd_funBody_ty, funBody_tc) <- tcExp ddefs init_s init_venv fenv tyvars False funBody + s2 <- unify funBody drvd_funBody_ty gvn_retty + pure $ fn { funTy = zonkTyScheme (s1 <> s2) funTy + , funBody = zonkExp (s1 <> s2) funBody_tc } + _ -> error $ "Expected a function type of form (ForAll ... (ArrowTy ...)), but got " ++ sdoc funTy case res of Left er -> error $ render er ++ " in " ++ show funName Right fn1 -> pure fn1 @@ -327,46 +328,55 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> DictEmptyP ty -> do len1 - let [a] = arg_tys' - s2 <- unify (args !! 0) ArenaTy a - case args !! 0 of - (VarE var) -> - pure (s1 <> s2, SymDictTy (Just var) ty, - PrimAppE pr args_tc) - Ext (L0.L _ (VarE var)) -> - pure (s1 <> s2, SymDictTy (Just var) ty, - PrimAppE pr args_tc) - _ -> err $ text "Expected arena variable argument in: " <+> exp_doc + case arg_tys' of + [a] -> do + s2 <- unify (args !! 0) ArenaTy a + case args !! 0 of + (VarE var) -> + pure (s1 <> s2, SymDictTy (Just var) ty, + PrimAppE pr args_tc) + Ext (L0.L _ (VarE var)) -> + pure (s1 <> s2, SymDictTy (Just var) ty, + PrimAppE pr args_tc) + _ -> err $ text "Expected arena variable argument in: " <+> exp_doc + _ -> error $ "Expected exactly one argument type in DictEmptyP, got: " ++ show arg_tys' + DictInsertP ty -> do len4 - let [a,d,k,v] = arg_tys' - s2 <- unify (args !! 1) (SymDictTy Nothing ty) d - s3 <- unify (args !! 2) SymTy0 k - s4 <- unify (args !! 3) ty v - s5 <- unify (args !! 0) ArenaTy a - case args !! 0 of - (VarE var) -> pure (s1 <> s2 <> s3 <> s4 <> s5, - SymDictTy (Just var) ty, - PrimAppE pr args_tc) - Ext (L0.L _ (VarE var)) -> pure (s1 <> s2 <> s3 <> s4 <> s5, - SymDictTy (Just var) ty, - PrimAppE pr args_tc) - _ -> err $ text "Expected arena variable argument in: " <+> exp_doc + case arg_tys' of + [a,d,k,v] -> do + s2 <- unify (args !! 1) (SymDictTy Nothing ty) d + s3 <- unify (args !! 2) SymTy0 k + s4 <- unify (args !! 3) ty v + s5 <- unify (args !! 0) ArenaTy a + case args !! 0 of + (VarE var) -> pure (s1 <> s2 <> s3 <> s4 <> s5, + SymDictTy (Just var) ty, + PrimAppE pr args_tc) + Ext (L0.L _ (VarE var)) -> pure (s1 <> s2 <> s3 <> s4 <> s5, + SymDictTy (Just var) ty, + PrimAppE pr args_tc) + _ -> err $ text "Expected arena variable argument in: " <+> exp_doc + _ -> error $ "Expected exactly four argument types in DictInsertP, got: " ++ show arg_tys' DictLookupP ty -> do len2 - let [d,k] = arg_tys' - s2 <- unify (args !! 0) (SymDictTy Nothing ty) d - s3 <- unify (args !! 1) SymTy0 k - pure (s1 <> s2 <> s3, ty, PrimAppE pr args_tc) + case arg_tys' of + [d,k] -> do + s2 <- unify (args !! 0) (SymDictTy Nothing ty) d + s3 <- unify (args !! 1) SymTy0 k + pure (s1 <> s2 <> s3, ty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in DictLookupP, got: " ++ show arg_tys' DictHasKeyP ty -> do len2 - let [d,k] = arg_tys' - s2 <- unify (args !! 0) (SymDictTy Nothing ty) d - s3 <- unify (args !! 1) SymTy0 k - pure (s1 <> s2 <> s3, BoolTy, PrimAppE pr args_tc) + case arg_tys' of + [d,k] -> do + s2 <- unify (args !! 0) (SymDictTy Nothing ty) d + s3 <- unify (args !! 1) SymTy0 k + pure (s1 <> s2 <> s3, BoolTy, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in DictHasKeyP, got: " ++ show arg_tys' IntHashEmpty -> do len0 @@ -387,56 +397,72 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> VAllocP elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) IntTy i - pure (s1 <> s2, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) IntTy i + pure (s1 <> s2, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in VAllocP, got: " ++ show arg_tys' VFreeP elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) i - pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) (VectorTy elty) i + pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in VFreeP, got: " ++ show arg_tys' VFree2P elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) i - pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) (VectorTy elty) i + pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in VFree2P, got: " ++ show arg_tys' VLengthP elty -> do len1 - let [ls] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) ls - pure (s1 <> s2, IntTy, PrimAppE pr args_tc) + case arg_tys' of + [ls] -> do + s2 <- unify (args !! 0) (VectorTy elty) ls + pure (s1 <> s2, IntTy, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in VLengthP, got: " ++ show arg_tys' VNthP elty -> do len2 - let [ls,i] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) ls - s3 <- unify (args !! 1) IntTy i - pure (s1 <> s2 <> s3, elty, PrimAppE pr args_tc) + case arg_tys' of + [ls,i] -> do + s2 <- unify (args !! 0) (VectorTy elty) ls + s3 <- unify (args !! 1) IntTy i + pure (s1 <> s2 <> s3, elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in VNthP, got: " ++ show arg_tys' VSliceP elty -> do len3 - let [from,to,ls] = arg_tys' - s2 <- unify (args !! 0) IntTy from - s3 <- unify (args !! 1) IntTy to - s4 <- unify (args !! 2) (VectorTy elty) ls - pure (s1 <> s2 <> s3 <> s3 <> s4, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [from,to,ls] -> do + s2 <- unify (args !! 0) IntTy from + s3 <- unify (args !! 1) IntTy to + s4 <- unify (args !! 2) (VectorTy elty) ls + pure (s1 <> s2 <> s3 <> s3 <> s4, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly three argument types in VSliceP, got: " ++ show arg_tys' InplaceVUpdateP elty -> do len3 - let [ls,i,val] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) ls - s3 <- unify (args !! 1) IntTy i - s4 <- unify (args !! 2) elty val - pure (s1 <> s2 <> s3 <> s4, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [ls,i,val] -> do + s2 <- unify (args !! 0) (VectorTy elty) ls + s3 <- unify (args !! 1) IntTy i + s4 <- unify (args !! 2) elty val + pure (s1 <> s2 <> s3 <> s4, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly three argument types in InplaceVUpdateP, got: " ++ show arg_tys' VConcatP elty -> do len1 - let [ls] = arg_tys' - s2 <- unify (args !! 0) (VectorTy (VectorTy elty)) ls - pure (s1 <> s2, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [ls] -> do + s2 <- unify (args !! 0) (VectorTy (VectorTy elty)) ls + pure (s1 <> s2, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in VConcatP, got: " ++ show arg_tys' -- Given that the first argument is a list of type (VectorTy t), -- ensure that the 2nd argument is function reference of type: @@ -445,10 +471,12 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> -- TODO: cannot unify if the 2nd argument is a lambda. VSortP elty -> do len2 - let [ls,fp] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) ls - s3 <- unify (args !! 1) (ArrowTy [elty, elty] IntTy) fp - pure (s1 <> s2 <> s3, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [ls,fp] -> do + s2 <- unify (args !! 0) (VectorTy elty) ls + s3 <- unify (args !! 1) (ArrowTy [elty, elty] IntTy) fp + pure (s1 <> s2 <> s3, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in VSortP, got: " ++ show arg_tys' InplaceVSortP elty -> do (s2, t, e) <- go (PrimAppE (VSortP elty) args) @@ -459,25 +487,31 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> VMergeP elty -> do len2 - let [ls1,ls2] = arg_tys' - s2 <- unify (args !! 0) (VectorTy elty) ls1 - s3 <- unify (args !! 1) (VectorTy elty) ls2 - pure (s1 <> s2 <> s3, VectorTy elty, PrimAppE pr args_tc) + case arg_tys' of + [ls1,ls2] -> do + s2 <- unify (args !! 0) (VectorTy elty) ls1 + s3 <- unify (args !! 1) (VectorTy elty) ls2 + pure (s1 <> s2 <> s3, VectorTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in VMergeP, got: " ++ show arg_tys' PDictInsertP kty vty -> do len3 - let [key, val, dict] = arg_tys' - s2 <- unify (args !! 0) key kty - s3 <- unify (args !! 1) val vty - s4 <- unify (args !! 2) dict (PDictTy kty vty) - pure (s1 <> s2 <> s3 <> s4, PDictTy kty vty, PrimAppE pr args_tc) + case arg_tys' of + [key, val, dict] -> do + s2 <- unify (args !! 0) key kty + s3 <- unify (args !! 1) val vty + s4 <- unify (args !! 2) dict (PDictTy kty vty) + pure (s1 <> s2 <> s3 <> s4, PDictTy kty vty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly three argument types in PDictInsertP, got: " ++ show arg_tys' PDictLookupP kty vty -> do len2 - let [key, dict] = arg_tys' - s2 <- unify (args !! 0) key kty - s3 <- unify (args !! 1) dict (PDictTy kty vty) - pure (s1 <> s2 <> s3, vty, PrimAppE pr args_tc) + case arg_tys' of + [key, dict] -> do + s2 <- unify (args !! 0) key kty + s3 <- unify (args !! 1) dict (PDictTy kty vty) + pure (s1 <> s2 <> s3, vty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in PDictLookupP, got: " ++ show arg_tys' PDictAllocP kty vty -> do len0 @@ -485,23 +519,29 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> PDictHasKeyP kty vty -> do len2 - let [key, dict] = arg_tys' - s2 <- unify (args !! 0) key kty - s3 <- unify (args !! 1) dict (PDictTy kty vty) - pure (s1 <> s2 <> s3, BoolTy, PrimAppE pr args_tc) + case arg_tys' of + [key, dict] -> do + s2 <- unify (args !! 0) key kty + s3 <- unify (args !! 1) dict (PDictTy kty vty) + pure (s1 <> s2 <> s3, BoolTy, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in PDictHasKeyP, got: " ++ show arg_tys' PDictForkP kty vty -> do len1 - let [dict] = arg_tys' - s2 <- unify (args !! 0) dict (PDictTy kty vty) - pure (s1 <> s2, ProdTy [PDictTy kty vty, PDictTy kty vty], PrimAppE pr args_tc) + case arg_tys' of + [dict] -> do + s2 <- unify (args !! 0) dict (PDictTy kty vty) + pure (s1 <> s2, ProdTy [PDictTy kty vty, PDictTy kty vty], PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in PDictForkP, got: " ++ show arg_tys' PDictJoinP kty vty -> do len2 - let [dict1, dict2] = arg_tys' - s2 <- unify (args !! 0) dict1 (PDictTy kty vty) - s3 <- unify (args !! 1) dict2 (PDictTy kty vty) - pure (s1 <> s2 <> s3, PDictTy kty vty, PrimAppE pr args_tc) + case arg_tys' of + [dict1, dict2] -> do + s2 <- unify (args !! 0) dict1 (PDictTy kty vty) + s3 <- unify (args !! 1) dict2 (PDictTy kty vty) + pure (s1 <> s2 <> s3, PDictTy kty vty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in PDictJoinP, got: " ++ show arg_tys' LLAllocP elty -> do len0 @@ -509,46 +549,60 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> LLIsEmptyP elty -> do len1 - let [ll] = arg_tys - s2 <- unify (args !! 0) ll (ListTy elty) - pure (s1 <> s2, BoolTy, PrimAppE pr args_tc) + case arg_tys of + [ll] -> do + s2 <- unify (args !! 0) ll (ListTy elty) + pure (s1 <> s2, BoolTy, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLIsEmptyP, got: " ++ show arg_tys LLConsP elty -> do len2 - let [elt, ll] = arg_tys - s2 <- unify (args !! 0) elt elty - s3 <- unify (args !! 1) ll (ListTy elty) - pure (s1 <> s2 <> s3, ListTy elty, PrimAppE pr args_tc) + case arg_tys of + [elt, ll] -> do + s2 <- unify (args !! 0) elt elty + s3 <- unify (args !! 1) ll (ListTy elty) + pure (s1 <> s2 <> s3, ListTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in LLConsP, got: " ++ show arg_tys LLHeadP elty -> do len1 - let [ll] = arg_tys - s2 <- unify (args !! 0) ll (ListTy elty) - pure (s1 <> s2, elty, PrimAppE pr args_tc) + case arg_tys of + [ll] -> do + s2 <- unify (args !! 0) ll (ListTy elty) + pure (s1 <> s2, elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLHeadP, got: " ++ show arg_tys LLTailP elty -> do len1 - let [ll] = arg_tys - s2 <- unify (args !! 0) ll (ListTy elty) - pure (s1 <> s2, ListTy elty, PrimAppE pr args_tc) + case arg_tys of + [ll] -> do + s2 <- unify (args !! 0) ll (ListTy elty) + pure (s1 <> s2, ListTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLTailP, got: " ++ show arg_tys LLFreeP elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) (ListTy elty) i - pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) (ListTy elty) i + pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLFreeP, got: " ++ show arg_tys' LLFree2P elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) (ListTy elty) i - pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) (ListTy elty) i + pure (s1 <> s2, ProdTy [], PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLFree2P, got: " ++ show arg_tys' LLCopyP elty -> do len1 - let [i] = arg_tys' - s2 <- unify (args !! 0) (ListTy elty) i - pure (s1 <> s2, ListTy elty, PrimAppE pr args_tc) + case arg_tys' of + [i] -> do + s2 <- unify (args !! 0) (ListTy elty) i + pure (s1 <> s2, ListTy elty, PrimAppE pr args_tc) + _ -> error $ "Expected exactly one argument type in LLCopyP, got: " ++ show arg_tys' GetNumProcessors -> do len0 @@ -564,10 +618,12 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> IsBig -> do len2 - let [ity, _ety] = arg_tys' - -- s1 <- unify (args !! 0) (PackedTy) - s2 <- unify (args !! 0) IntTy ity - pure (s1 <> s2, BoolTy, PrimAppE pr args_tc) + case arg_tys' of + [ity, _ety] -> do + -- s1 <- unify (args !! 0) (PackedTy) + s2 <- unify (args !! 0) IntTy ity + pure (s1 <> s2, BoolTy, PrimAppE pr args_tc) + _ -> error $ "Expected exactly two argument types in IsBig, got: " ++ show arg_tys' ReadPackedFile _fp _tycon _reg ty -> do len0 @@ -578,10 +634,12 @@ tcExp ddefs sbst venv fenv bound_tyvars is_main ex = (\(a,b,c) -> (a,b,c)) <$> pure (s1, VectorTy ty, PrimAppE pr args_tc) WritePackedFile fp ty -> do - len1 - let [packed_ty] = arg_tys' - s2 <- unify (args !! 0) ty packed_ty - pure (s1 <> s2, ProdTy [], PrimAppE (WritePackedFile fp (zonkTy s2 ty)) args_tc) + len1 + case arg_tys' of + [packed_ty] -> do + s2 <- unify (args !! 0) ty packed_ty + pure (s1 <> s2, ProdTy [], PrimAppE (WritePackedFile fp (zonkTy s2 ty)) args_tc) + _ -> error $ "Expected exactly one argument type in WritePackedFile, got: " ++ show arg_tys' Write3dPpmFile{} -> err $ text "Write3dPpmFile" RequestSizeOf-> err $ text "Unexpected RequestSizeOf in L0: " <+> exp_doc diff --git a/gibbon-compiler/src/Gibbon/L1/Typecheck.hs b/gibbon-compiler/src/Gibbon/L1/Typecheck.hs index 7ce7a0a22..737b9dde5 100644 --- a/gibbon-compiler/src/Gibbon/L1/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L1/Typecheck.hs @@ -265,48 +265,61 @@ tcExp ddfs env exp = DictEmptyP ty -> do len1 - let [a] = tys - _ <- ensureEqualTy exp ArenaTy a - case (es !! 0) of - (VarE var) -> do ensureArenaScope exp env $ Just var - return $ SymDictTy (Just var) ty - _ -> throwError $ GenericTC "Expected arena variable argument" exp + case tys of + [a] -> do + _ <- ensureEqualTy exp ArenaTy a + case (es !! 0) of + (VarE var) -> do + ensureArenaScope exp env $ Just var + return $ SymDictTy (Just var) ty + _ -> throwError $ GenericTC "Expected arena variable argument" exp + _ -> throwError $ GenericTC "DictEmptyP expects exactly 1 type argument" exp DictInsertP ty -> do len4 - let [a,d,k,v] = tys - _ <- ensureEqualTy exp ArenaTy a - case d of - SymDictTy ar dty -> do _ <- ensureEqualTy exp SymTy k - _ <- ensureEqualTy exp ty v - _ <- ensureEqualTy exp ty dty - ensureArenaScope exp env ar - case es !!! 0 of - (VarE var) -> do ensureArenaScope exp env $ Just var - return $ SymDictTy (Just var) ty - _ -> throwError $ GenericTC "Expected arena variable argument" exp - _ -> throwError $ GenericTC "Expected SymDictTy" exp + case tys of + [a,d,k,v] -> do + _ <- ensureEqualTy exp ArenaTy a + case d of + SymDictTy ar dty -> do + _ <- ensureEqualTy exp SymTy k + _ <- ensureEqualTy exp ty v + _ <- ensureEqualTy exp ty dty + ensureArenaScope exp env ar + case es !!! 0 of + (VarE var) -> do + ensureArenaScope exp env $ Just var + return $ SymDictTy (Just var) ty + _ -> throwError $ GenericTC "Expected arena variable argument" exp + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "DictInsertP expects exactly 4 type arguments" exp DictLookupP ty -> do len2 - let [d,k] = tys - case d of - SymDictTy ar dty -> do _ <- ensureEqualTy exp SymTy k - _ <- ensureEqualTy exp ty dty - -- dbgTrace 3 (show $ vEnv env) $ return () - ensureArenaScope exp env ar - return ty - _ -> throwError $ GenericTC "Expected SymDictTy" exp + case tys of + [d,k] -> do + case d of + SymDictTy ar dty -> do + _ <- ensureEqualTy exp SymTy k + _ <- ensureEqualTy exp ty dty + -- dbgTrace 3 (show $ vEnv env) $ return () + ensureArenaScope exp env ar + return ty + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "DictLookupP expects exactly 2 type arguments" exp DictHasKeyP ty -> do len2 - let [d,k] = tys - case d of - SymDictTy ar dty -> do _ <- ensureEqualTy exp SymTy k - _ <- ensureEqualTy exp ty dty - ensureArenaScope exp env ar - return BoolTy - _ -> throwError $ GenericTC "Expected SymDictTy" exp + case tys of + [d,k] -> do + case d of + SymDictTy ar dty -> do + _ <- ensureEqualTy exp SymTy k + _ <- ensureEqualTy exp ty dty + ensureArenaScope exp env ar + return BoolTy + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "DictHasKeyP expects exactly 2 type arguments" exp ErrorP _str ty -> do len0 @@ -318,11 +331,13 @@ tcExp ddfs env exp = IsBig -> do len2 - let [ity,ety] = tys - _ <- ensureEqualTy exp ity IntTy - if isPackedTy ety - then pure BoolTy - else error $ "L1.Typecheck: IsBig expects a Packed value. Got: " ++ sdoc ety + case tys of + [ity,ety] -> do + _ <- ensureEqualTy exp ity IntTy + if isPackedTy ety + then pure BoolTy + else error $ "L1.Typecheck: IsBig expects a Packed value. Got: " ++ sdoc ety + _ -> throwError $ GenericTC ("IsBig expects exactly 2 type arguments, got " ++ show tys) exp ReadPackedFile _fp _tycon _reg ty -> do len0 @@ -331,9 +346,11 @@ tcExp ddfs env exp = WritePackedFile _ ty | PackedTy{} <- ty -> do len1 - let [packed_ty] = tys - _ <- ensureEqualTy exp packed_ty ty - pure (ProdTy []) + case tys of + [packed_ty] -> do + _ <- ensureEqualTy exp packed_ty ty + pure (ProdTy []) + _ -> throwError $ GenericTC ("WritePackedFile expects exactly 1 type argument, got " ++ show tys) exp | otherwise -> error $ "writePackedFile expects a packed type. Given" ++ sdoc ty ReadArrayFile _ ty -> do @@ -356,63 +373,79 @@ tcExp ddfs env exp = VAllocP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) IntTy i - pure (VectorTy elty) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) IntTy i + pure (VectorTy elty) + _ -> throwError $ GenericTC ("VAllocP expects exactly 1 type argument, got " ++ show tys) exp VFreeP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy []) + _ -> throwError $ GenericTC ("VFreeP expects exactly 1 type argument, got " ++ show tys) exp VFree2P elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy []) + _ -> throwError $ GenericTC ("VFree2P expects exactly 1 type argument, got " ++ show tys) exp VLengthP elty -> do len1 checkListElemTy elty - let [ls] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - pure IntTy + case tys of + [ls] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + pure IntTy + _ -> throwError $ GenericTC ("VLengthP expects exactly 1 type argument, got " ++ show tys) exp VNthP elty -> do len2 checkListElemTy elty - let [ls, i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - _ <- ensureEqualTy (es !! 1) IntTy i - pure elty + case tys of + [ls, i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + _ <- ensureEqualTy (es !! 1) IntTy i + pure elty + _ -> throwError $ GenericTC ("VNthP expects exactly 2 type arguments, got " ++ show tys) exp VSliceP elty -> do len3 checkListElemTy elty - let [from,to,ls] = tys - _ <- ensureEqualTy (es !! 0) IntTy from - _ <- ensureEqualTy (es !! 1) IntTy to - _ <- ensureEqualTy (es !! 2) (VectorTy elty) ls - pure (VectorTy elty) + case tys of + [from,to,ls] -> do + _ <- ensureEqualTy (es !! 0) IntTy from + _ <- ensureEqualTy (es !! 1) IntTy to + _ <- ensureEqualTy (es !! 2) (VectorTy elty) ls + pure (VectorTy elty) + _ -> throwError $ GenericTC ("VSliceP expects exactly 3 type arguments, got " ++ show tys) exp InplaceVUpdateP elty -> do len3 checkListElemTy elty - let [ls,i,x] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - _ <- ensureEqualTy (es !! 1) IntTy i - _ <- ensureEqualTy (es !! 2) elty x - pure (VectorTy elty) + case tys of + [ls,i,x] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + _ <- ensureEqualTy (es !! 1) IntTy i + _ <- ensureEqualTy (es !! 2) elty x + pure (VectorTy elty) + _ -> throwError $ GenericTC ("VInplaceVUpdateP expects exactly 3 type arguments, got " ++ show tys) exp VConcatP elty -> do len1 checkListElemTy elty - let [ls] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls - pure (VectorTy elty) + case tys of + [ls] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls + pure (VectorTy elty) + _ -> throwError $ GenericTC ("VConcatP expects exactly 1 type argument, got " ++ show tys) exp -- Given that the first argument is a list of type (VectorTy t), -- ensure that the 2nd argument is function reference of type: @@ -421,18 +454,20 @@ tcExp ddfs env exp = case (es !! 1) of VarE f -> do len2 - let [ls] = tys - fn_ty@(in_tys, ret_ty) = lookupFEnv f env - err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - case in_tys of - [a,b] -> do - -- [2021.05.08]: looks suspicious - _ <- ensureEqualTy (es !! 1) a elty - _ <- ensureEqualTy (es !! 1) b elty - _ <- ensureEqualTy (es !! 1) ret_ty IntTy - pure (VectorTy elty) - _ -> err fn_ty + case tys of + [ls] -> do + let fn_ty@(in_tys, ret_ty) = lookupFEnv f env + err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + case in_tys of + [a,b] -> do + -- [2021.05.08]: looks suspicious + _ <- ensureEqualTy (es !! 1) a elty + _ <- ensureEqualTy (es !! 1) b elty + _ <- ensureEqualTy (es !! 1) ret_ty IntTy + pure (VectorTy elty) + _ -> err fn_ty + _ -> throwError $ GenericTC ("VSortPP expects exactly 1 type argument, got " ++ show tys) exp oth -> throwError $ GenericTC ("vsort: function pointer has to be a variable reference. Got"++ sdoc oth) exp InplaceVSortP elty -> go (PrimAppE (VSortP elty) es) @@ -440,30 +475,36 @@ tcExp ddfs env exp = VMergeP elty -> do len2 checkListElemTy elty - let [ls1,ls2] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 - _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 - pure (VectorTy elty) + case tys of + [ls1,ls2] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 + _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 + pure (VectorTy elty) + _ -> throwError $ GenericTC ("VMergeP expects exactly 2 type arguments, got " ++ show tys) exp PDictInsertP kty vty -> do len3 checkListElemTy kty checkListElemTy vty - let [key, val, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 1) val vty - _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) - pure (PDictTy kty vty) + case tys of + [key, val, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 1) val vty + _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) + pure (PDictTy kty vty) + _ -> throwError $ GenericTC ("PDictInsertP expects exactly 3 type arguments, got " ++ show tys) exp PDictLookupP kty vty -> do len2 checkListElemTy kty checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (vty) + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (vty) + _ -> throwError $ GenericTC ("PDictLookupP expects exactly 2 type arguments, got " ++ show tys) exp PDictAllocP kty vty -> do len0 @@ -475,27 +516,33 @@ tcExp ddfs env exp = len2 checkListElemTy kty checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (BoolTy) + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (BoolTy) + _ -> throwError $ GenericTC ("PDictHasKeyP expects exactly 2 type arguments, got " ++ show tys) exp PDictForkP kty vty -> do len1 checkListElemTy kty checkListElemTy vty - let [dict] = tys - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (ProdTy [PDictTy kty vty, PDictTy kty vty]) + case tys of + [dict] -> do + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (ProdTy [PDictTy kty vty, PDictTy kty vty]) + _ -> throwError $ GenericTC ("PDictForkP expects exactly 1 type argument, given " ++ show tys) exp PDictJoinP kty vty -> do len2 checkListElemTy kty checkListElemTy vty - let [dict1, dict2] = tys - _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) - _ <- ensureEqualTy (es !! 0) dict2 (PDictTy kty vty) - pure (PDictTy kty vty) + case tys of + [dict1, dict2] -> do + _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) + _ <- ensureEqualTy (es !! 0) dict2 (PDictTy kty vty) + pure (PDictTy kty vty) + _ -> throwError $ GenericTC ("PDictJoinP expects exactly 2 type arguments, given " ++ show tys) exp LLAllocP elty -> do len0 @@ -505,52 +552,66 @@ tcExp ddfs env exp = LLIsEmptyP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (BoolTy) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (BoolTy) + _ -> throwError $ GenericTC ("LLIsEmptyP expects exactly 1 type argument, given " ++ show tys) exp LLConsP elty -> do len2 checkListElemTy elty - let [elt, ll] = tys - _ <- ensureEqualTy (es !! 0) elt elty - _ <- ensureEqualTy (es !! 1) ll (ListTy elty) - pure (ListTy elty) + case tys of + [elt, ll] -> do + _ <- ensureEqualTy (es !! 0) elt elty + _ <- ensureEqualTy (es !! 1) ll (ListTy elty) + pure (ListTy elty) + _ -> throwError $ GenericTC ("LLIsConsP expects exactly 2 type arguments, given " ++ show tys) exp LLHeadP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (elty) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (elty) + _ -> throwError $ GenericTC ("LLHeapP expects exactly 1 type argument, given " ++ show tys) exp LLTailP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (ListTy elty) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (ListTy elty) + _ -> throwError $ GenericTC ("LLTailP expects exactly 1 type argument, given " ++ show tys) exp LLFreeP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy []) + _ -> throwError $ GenericTC ("LLFreeP expects exactly 1 type argument, given " ++ show tys) exp LLFree2P elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy []) + _ -> throwError $ GenericTC ("LLFree2P expects exactly 1 type argument, given " ++ show tys) exp LLCopyP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ListTy elty) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ListTy elty) + _ -> throwError $ GenericTC ("LLCopyP expects exactly 1 type argument, given " ++ show tys) exp GetNumProcessors -> do len0 @@ -632,11 +693,13 @@ tcExp ddfs env exp = case L.nub tycons of [one] -> do -- _ <- ensureEqualTy exp (PackedTy one ()) tye - let (PackedTy t _l) = tye - if one == t - then return () - else error$ "Expected these to be the same: " ++ one ++ " & " ++ sdoc t - tcCases ddfs env cs + case tye of + (PackedTy t _l) -> do + if one == t + then return () + else error$ "Expected these to be the same: " ++ one ++ " & " ++ sdoc t + tcCases ddfs env cs + ty -> throwError $ GenericTC ("Expected packed type, got " ++ show ty) exp oth -> throwError $ GenericTC ("Case branches have mismatched types: " ++ sdoc oth ++" , in " ++ sdoc exp) exp diff --git a/gibbon-compiler/src/Gibbon/L2/Interp.hs b/gibbon-compiler/src/Gibbon/L2/Interp.hs index eaecba146..9533cec2c 100644 --- a/gibbon-compiler/src/Gibbon/L2/Interp.hs +++ b/gibbon-compiler/src/Gibbon/L2/Interp.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 062587b9c..51c4f68fd 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -898,8 +898,10 @@ revertExp ex = AppE v _ args -> AppE v [] (L.map revertExp args) PrimAppE p args -> PrimAppE (revertPrim p) $ L.map revertExp args LetE (v,_,ty, (Ext (IndirectionE _ _ _ _ arg))) bod -> - let PackedTy tycon _ = ty in + case ty of + PackedTy tycon _ -> LetE (v,[],(stripTyLocs ty), AppE (mkCopyFunName tycon) [] [revertExp arg]) (revertExp bod) + _ -> error $ "revertExp: expected PackedTy, got " ++ show ty LetE (v,_,ty,rhs) bod -> LetE (v,[], stripTyLocs ty, revertExp rhs) (revertExp bod) IfE a b c -> IfE (revertExp a) (revertExp b) (revertExp c) diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index 469d36ae7..e0fc1bfbc 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -193,495 +193,552 @@ tcExp ddfs env funs constrs regs tstatein exp = return (arrOut',tstate') PrimAppE pr es -> do - -- Special case because we can't lookup the type of the function pointer - let es' = case pr of - VSortP{} -> init es - InplaceVSortP{} -> init es - _ -> es - (tys,tstate) <- tcExps ddfs env funs constrs regs tstatein es' - - -- Pattern matches would be one way to check length safely, but then the - -- error would not go through our monad: - let len2 = checkLen exp pr 2 es - len1 = checkLen exp pr 1 es - len0 = checkLen exp pr 0 es - len3 = checkLen exp pr 3 es - len4 = checkLen exp pr 4 es - - mk_bools = do - len0 - pure (BoolTy, tstate) - - bool_ops = do - len2 - _ <- ensureEqualTy (es !! 0) BoolTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) BoolTy (tys !! 1) - pure (BoolTy, tstate) - - int_ops = do - len2 - _ <- ensureEqualTy (es !! 0) IntTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) IntTy (tys !! 1) - pure (IntTy, tstate) - - float_ops = do - len2 - _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) - pure (FloatTy, tstate) - - int_cmps = do - len2 - _ <- ensureEqualTy (es !! 0) IntTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) IntTy (tys !! 1) - pure (BoolTy, tstate) - - float_cmps = do - len2 - _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) - pure (BoolTy, tstate) - - char_cmps = do - len2 - _ <- ensureEqualTy (es !! 0) CharTy (tys !! 0) - _ <- ensureEqualTy (es !! 1) CharTy (tys !! 1) - pure (BoolTy, tstate) - - case pr of - MkTrue -> mk_bools - MkFalse -> mk_bools - AddP -> int_ops - SubP -> int_ops - MulP -> int_ops - DivP -> int_ops - ModP -> int_ops - ExpP -> int_ops - FAddP -> float_ops - FSubP -> float_ops - FMulP -> float_ops - FDivP -> float_ops - FExpP -> float_ops - EqIntP -> int_cmps - LtP -> int_cmps - GtP -> int_cmps - LtEqP -> int_cmps - GtEqP -> int_cmps - EqFloatP -> float_cmps - EqCharP -> char_cmps - FLtP -> float_cmps - FGtP -> float_cmps - FLtEqP -> float_cmps - FGtEqP -> float_cmps - OrP -> bool_ops - AndP -> bool_ops - - RandP -> return (IntTy, tstate) - FRandP -> return (FloatTy, tstate) - - FloatToIntP -> do - len1 - ensureEqualTy exp FloatTy (tys !! 0) - return (IntTy, tstate) - - IntToFloatP -> do - len1 - ensureEqualTy exp IntTy (tys !! 0) - return (FloatTy, tstate) - - FSqrtP -> do - len1 - ensureEqualTy exp FloatTy (tys !! 0) - return (FloatTy, tstate) - - FTanP -> do - len1 - ensureEqualTy exp FloatTy (tys !! 0) - return (FloatTy, tstate) - - Gensym -> len0 >>= \_ -> pure (SymTy, tstate) - - EqSymP -> do - len2 - ensureEqualTy exp SymTy (tys !! 0) - ensureEqualTy exp SymTy (tys !! 1) - return (BoolTy,tstate) - - EqBenchProgP _ -> do - len0 - return (BoolTy,tstate) - - DictEmptyP ty -> do - len1 - let [a] = tys - _ <- ensureEqualTy exp ArenaTy a - case es !! 0 of - (VarE var) -> - do ensureArenaScope exp env (Just var) + -- Special case because we can't lookup the type of the function pointer + let es' = case pr of + VSortP{} -> init es + InplaceVSortP{} -> init es + _ -> es + (tys,tstate) <- tcExps ddfs env funs constrs regs tstatein es' + + -- Pattern matches would be one way to check length safely, but then the + -- error would not go through our monad: + let len2 = checkLen exp pr 2 es + len1 = checkLen exp pr 1 es + len0 = checkLen exp pr 0 es + len3 = checkLen exp pr 3 es + len4 = checkLen exp pr 4 es + + mk_bools = do + len0 + pure (BoolTy, tstate) + + bool_ops = do + len2 + _ <- ensureEqualTy (es !! 0) BoolTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) BoolTy (tys !! 1) + pure (BoolTy, tstate) + + int_ops = do + len2 + _ <- ensureEqualTy (es !! 0) IntTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) IntTy (tys !! 1) + pure (IntTy, tstate) + + float_ops = do + len2 + _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) + pure (FloatTy, tstate) + + int_cmps = do + len2 + _ <- ensureEqualTy (es !! 0) IntTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) IntTy (tys !! 1) + pure (BoolTy, tstate) + + float_cmps = do + len2 + _ <- ensureEqualTy (es !! 0) FloatTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) FloatTy (tys !! 1) + pure (BoolTy, tstate) + + char_cmps = do + len2 + _ <- ensureEqualTy (es !! 0) CharTy (tys !! 0) + _ <- ensureEqualTy (es !! 1) CharTy (tys !! 1) + pure (BoolTy, tstate) + + case pr of + MkTrue -> mk_bools + MkFalse -> mk_bools + AddP -> int_ops + SubP -> int_ops + MulP -> int_ops + DivP -> int_ops + ModP -> int_ops + ExpP -> int_ops + FAddP -> float_ops + FSubP -> float_ops + FMulP -> float_ops + FDivP -> float_ops + FExpP -> float_ops + EqIntP -> int_cmps + LtP -> int_cmps + GtP -> int_cmps + LtEqP -> int_cmps + GtEqP -> int_cmps + EqFloatP -> float_cmps + EqCharP -> char_cmps + FLtP -> float_cmps + FGtP -> float_cmps + FLtEqP -> float_cmps + FGtEqP -> float_cmps + OrP -> bool_ops + AndP -> bool_ops + + RandP -> return (IntTy, tstate) + FRandP -> return (FloatTy, tstate) + + FloatToIntP -> do + len1 + ensureEqualTy exp FloatTy (tys !! 0) + return (IntTy, tstate) + + IntToFloatP -> do + len1 + ensureEqualTy exp IntTy (tys !! 0) + return (FloatTy, tstate) + + FSqrtP -> do + len1 + ensureEqualTy exp FloatTy (tys !! 0) + return (FloatTy, tstate) + + FTanP -> do + len1 + ensureEqualTy exp FloatTy (tys !! 0) + return (FloatTy, tstate) + + Gensym -> len0 >>= \_ -> pure (SymTy, tstate) + + EqSymP -> do + len2 + ensureEqualTy exp SymTy (tys !! 0) + ensureEqualTy exp SymTy (tys !! 1) + return (BoolTy,tstate) + + EqBenchProgP _ -> do + len0 + return (BoolTy,tstate) + + DictEmptyP ty -> do + len1 + case tys of + [a] -> do + _ <- ensureEqualTy exp ArenaTy a + case es !! 0 of + (VarE var) -> do + ensureArenaScope exp env (Just var) return (SymDictTy (Just var) (stripTyLocs ty), tstate) - _ -> throwError $ GenericTC "Expected arena variable argument" exp - - DictInsertP ty -> do - len4 - let [a,d,k,v] = tys - _ <- ensureEqualTy exp ArenaTy a - _ <- ensureEqualTy exp SymTy k - _ <- ensureEqualTyNoLoc exp ty v - case d of - SymDictTy ar _ty -> - case es !! 0 of - (VarE var) -> - do ensureArenaScope exp env ar - ensureArenaScope exp env (Just var) - return (SymDictTy (Just var) (stripTyLocs ty), tstate) - _ -> throwError $ GenericTC "Expected arena variable argument" exp - _ -> throwError $ GenericTC "Expected SymDictTy" exp - - DictLookupP ty -> do - len2 - let [d,k] = tys - case d of - SymDictTy ar _ty -> - do _ <- ensureEqualTy exp SymTy k - ensureArenaScope exp env ar - return (ty, tstate) - _ -> throwError $ GenericTC "Expected SymDictTy" exp - - DictHasKeyP _ty -> do - len2 - let [d,k] = tys - case d of - SymDictTy ar _ty -> do _ <- ensureEqualTy exp SymTy k - ensureArenaScope exp env ar - return (BoolTy, tstate) - _ -> throwError $ GenericTC "Expected SymDictTy" exp - - SizeParam -> do - len0 - return (IntTy, tstate) - - IsBig -> do - len2 - let [ity, ety] = tys - ensureEqualTy exp ity IntTy - if isPackedTy ety - then pure (BoolTy, tstate) - else error "L1.Typecheck: IsBig expects a Packed value." - - ErrorP _str ty -> do - len0 - return (ty, tstate) - - ReadPackedFile _fp _tycon _reg ty -> do - len0 - return (ty, tstate) - - WritePackedFile _ ty - | PackedTy{} <- ty -> do - len1 - let [packed_ty] = tys - _ <- ensureEqualTy exp packed_ty ty - pure (ProdTy [], tstate) - | otherwise -> error $ "writePackedFile expects a packed type. Given" ++ sdoc ty - - ReadArrayFile _ ty -> do - len0 - if isValidListElemTy ty - then return (VectorTy ty, tstate) - else throwError $ GenericTC "Not a valid list type" exp - - RequestSizeOf -> do - len1 - case (es !! 0) of - VarE{} -> if isPackedTy (tys !! 0) - then return (IntTy, tstate) - else case (tys !! 0) of - SymTy -> return (IntTy, tstate) - IntTy -> return (IntTy, tstate) - _ -> throwError $ GenericTC "Expected PackedTy" exp - _ -> throwError $ GenericTC "Expected a variable argument" exp - - VAllocP elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) IntTy i - pure (VectorTy elty, tstate) - - VFreeP elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy [], tstate) - - VFree2P elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy [], tstate) - - VLengthP elty -> do - let [ls] = tys - _ <- ensureEqualTy exp (VectorTy elty) ls - pure (IntTy, tstate) - - VNthP elty -> do - let [ls, i] = tys - _ <- ensureEqualTy exp (VectorTy elty) ls - _ <- ensureEqualTy exp IntTy i - pure (elty, tstate) - - VSliceP elty -> do - let [from,to,ls] = tys - _ <- ensureEqualTy exp IntTy from - _ <- ensureEqualTy exp IntTy to - _ <- ensureEqualTy exp (VectorTy elty) ls - pure (VectorTy elty, tstate) - - InplaceVUpdateP elty -> do - let [ls,i,val] = tys - _ <- ensureEqualTy exp (VectorTy elty) ls - _ <- ensureEqualTy exp IntTy i - _ <- ensureEqualTy exp elty val - pure (VectorTy elty, tstate) - - VConcatP elty -> do - len1 - let [ls] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls - pure (VectorTy elty, tstate) - - - -- Given that the first argument is a list of type (VectorTy t), - -- ensure that the 2nd argument is function reference of type: - -- ty -> ty -> Bool - VSortP elty -> - case (es !! 1) of - VarE f -> do - len2 - let [ls] = tys - fn_ty = lookupFEnvLocVar (fromVarToFreeVarsTy f) env - in_tys = inTys fn_ty - ret_ty = outTy fn_ty - err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - case in_tys of - [a,b] -> do - _ <- ensureEqualTy (es !! 1) a elty - _ <- ensureEqualTy (es !! 1) b elty - _ <- ensureEqualTy (es !! 1) ret_ty IntTy - pure (VectorTy elty, tstate) - _ -> err fn_ty - oth -> throwError $ GenericTC ("vsort: function pointer has to be a variable reference. Got"++ sdoc oth) exp - - InplaceVSortP elty -> recur tstatein (PrimAppE (VSortP elty) es) - - VMergeP elty -> do - len2 - checkListElemTy elty - let [ls1,ls2] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 - _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 - pure (VectorTy elty, tstate) - - PDictInsertP kty vty -> do - len3 - checkListElemTy kty - checkListElemTy vty - let [key, val, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 1) val vty - _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) - pure (PDictTy kty vty, tstate) - - PDictLookupP kty vty -> do - len2 - checkListElemTy kty - checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 1) dict (PDictTy kty vty) - pure (vty, tstate) - - PDictAllocP kty vty -> do - len0 - checkListElemTy kty - checkListElemTy vty - pure (PDictTy kty vty, tstate) - - PDictHasKeyP kty vty -> do - len2 - checkListElemTy kty - checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 1) dict (PDictTy kty vty) - pure (BoolTy, tstate) - - PDictForkP kty vty -> do - len1 - checkListElemTy kty - checkListElemTy vty - let [dict] = tys - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (ProdTy [PDictTy kty vty, PDictTy kty vty], tstate) - - PDictJoinP kty vty -> do - len2 - checkListElemTy kty - checkListElemTy vty - let [dict1, dict2] = tys - _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) - _ <- ensureEqualTy (es !! 1) dict2 (PDictTy kty vty) - pure (PDictTy kty vty, tstate) - - LLAllocP elty -> do - len0 - checkListElemTy elty - pure (ListTy elty, tstate) - - LLIsEmptyP elty -> do - len1 - checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (BoolTy, tstate) - - LLConsP elty -> do - len2 - checkListElemTy elty - let [elt, ll] = tys - _ <- ensureEqualTy (es !! 0) elt elty - _ <- ensureEqualTy (es !! 1) ll (ListTy elty) - pure (ListTy elty, tstate) - - LLHeadP elty -> do - len1 - checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (elty, tstate) - - LLTailP elty -> do - len1 - checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (ListTy elty, tstate) - - LLFreeP elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy [], tstate) - - LLFree2P elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy [], tstate) - - LLCopyP elty -> do - len1 - checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ListTy elty, tstate) - - GetNumProcessors -> do - len0 - pure (IntTy, tstate) - - PrintInt -> do - len1 - _ <- ensureEqualTy (es !!! 0) IntTy (tys !!! 0) - pure (ProdTy [], tstate) - - PrintChar -> do - len1 - _ <- ensureEqualTy (es !!! 0) CharTy (tys !!! 0) - pure (ProdTy [], tstate) - - PrintFloat -> do - len1 - _ <- ensureEqualTy (es !!! 0) FloatTy (tys !!! 0) - pure (ProdTy [], tstate) - - PrintBool -> do - len1 - _ <- ensureEqualTy (es !!! 0) BoolTy (tys !!! 0) - pure (ProdTy [], tstate) - - PrintSym -> do - len1 - _ <- ensureEqualTy (es !!! 0) SymTy (tys !!! 0) - pure (ProdTy [], tstate) - - ReadInt -> throwError $ GenericTC "ReadInt not handled" exp - - SymSetEmpty -> do - len0 - pure (SymSetTy, tstate) - - SymSetInsert -> do - len2 - _ <- ensureEqualTy (es !!! 0) SymSetTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - pure (SymSetTy, tstate) - - SymSetContains -> do - len2 - _ <- ensureEqualTy (es !!! 0) SymSetTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - pure (BoolTy, tstate) - - SymHashEmpty -> do - len0 - pure (SymHashTy, tstate) - - SymHashInsert -> do - len3 - _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - _ <- ensureEqualTy (es !!! 2) SymTy (tys !!! 2) - pure (SymHashTy, tstate) - - SymHashLookup -> do - len2 - _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - pure (SymTy, tstate) - - SymHashContains -> do - len2 - _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - pure (BoolTy, tstate) - - IntHashEmpty -> do - len0 - pure (IntHashTy, tstate) - - IntHashInsert -> do - len3 - _ <- ensureEqualTy (es !!! 0) IntHashTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - _ <- ensureEqualTy (es !!! 2) IntTy (tys !!! 2) - pure (IntHashTy, tstate) - - IntHashLookup -> do - len2 - _ <- ensureEqualTy (es !!! 0) IntHashTy (tys !!! 0) - _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) - pure (IntTy, tstate) - - Write3dPpmFile{} -> throwError $ GenericTC "Write3dPpmFile not handled yet" exp - - RequestEndOf{} -> throwError $ GenericTC "tcExp of PrimAppE: RequestEndOf not handled yet" exp + _ -> throwError $ GenericTC "Expected arena variable argument" exp + _ -> throwError $ GenericTC "Expected exactly one type argument" exp + + DictInsertP ty -> do + len4 + case tys of + [a,d,k,v] -> do + _ <- ensureEqualTy exp ArenaTy a + _ <- ensureEqualTy exp SymTy k + _ <- ensureEqualTyNoLoc exp ty v + case d of + SymDictTy ar _ty -> + case es !! 0 of + (VarE var) -> + do ensureArenaScope exp env ar + ensureArenaScope exp env (Just var) + return (SymDictTy (Just var) (stripTyLocs ty), tstate) + _ -> throwError $ GenericTC "Expected arena variable argument" exp + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "Expected exactly 4 types in DictInsertP" exp + + DictLookupP ty -> do + len2 + case tys of + [d,k] -> do + case d of + SymDictTy ar _ty -> + do _ <- ensureEqualTy exp SymTy k + ensureArenaScope exp env ar + return (ty, tstate) + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "Expected exactly 2 types in DictLookupP" exp + + DictHasKeyP _ty -> do + len2 + case tys of + [d,k] -> do + case d of + SymDictTy ar _ty -> do + _ <- ensureEqualTy exp SymTy k + ensureArenaScope exp env ar + return (BoolTy, tstate) + _ -> throwError $ GenericTC "Expected SymDictTy" exp + _ -> throwError $ GenericTC "Expected exactly 2 types in DictHasKeyP" exp + + SizeParam -> do + len0 + return (IntTy, tstate) + + IsBig -> do + len2 + case tys of + [ity, ety] -> do + ensureEqualTy exp ity IntTy + if isPackedTy ety + then pure (BoolTy, tstate) + else error "L1.Typecheck: IsBig expects a Packed value." + _ -> error "Expected exactly 2 types in IsBig" + + ErrorP _str ty -> do + len0 + return (ty, tstate) + + ReadPackedFile _fp _tycon _reg ty -> do + len0 + return (ty, tstate) + + WritePackedFile _ ty + | PackedTy{} <- ty -> do + len1 + case tys of + [packed_ty] -> do + _ <- ensureEqualTy exp packed_ty ty + pure (ProdTy [], tstate) + _ -> error $ "writePackedFile expects exactly 1 type argument. Given: " ++ show tys + | otherwise -> error $ "writePackedFile expects a packed type. Given" ++ sdoc ty + + ReadArrayFile _ ty -> do + len0 + if isValidListElemTy ty + then return (VectorTy ty, tstate) + else throwError $ GenericTC "Not a valid list type" exp + + RequestSizeOf -> do + len1 + case (es !! 0) of + VarE{} -> if isPackedTy (tys !! 0) + then return (IntTy, tstate) + else case (tys !! 0) of + SymTy -> return (IntTy, tstate) + IntTy -> return (IntTy, tstate) + _ -> throwError $ GenericTC "Expected PackedTy" exp + _ -> throwError $ GenericTC "Expected a variable argument" exp + + VAllocP elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) IntTy i + pure (VectorTy elty, tstate) + _ -> error $ "VAllocP expects exactly 1 type argument. Given: " ++ show tys + + VFreeP elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy [], tstate) + _ -> error $ "VFreeP expects exactly 1 type argument. Given: " ++ show tys + + VFree2P elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy [], tstate) + _ -> error $ "VFreeP2 expects exactly 1 type argument. Given: " ++ show tys + + VLengthP elty -> do + case tys of + [ls] -> do + _ <- ensureEqualTy exp (VectorTy elty) ls + pure (IntTy, tstate) + _ -> error $ "VLengthP expects exactly 1 type argument. Given: " ++ show tys + + VNthP elty -> do + case tys of + [ls, i] -> do + _ <- ensureEqualTy exp (VectorTy elty) ls + _ <- ensureEqualTy exp IntTy i + pure (elty, tstate) + _ -> error $ "VFreeP expects exactly 2 type arguments. Given: " ++ show tys + + VSliceP elty -> do + case tys of + [from,to,ls] -> do + _ <- ensureEqualTy exp IntTy from + _ <- ensureEqualTy exp IntTy to + _ <- ensureEqualTy exp (VectorTy elty) ls + pure (VectorTy elty, tstate) + _ -> error $ "VSliceP expects exactly 3 type argument. Given: " ++ show tys + + InplaceVUpdateP elty -> do + case tys of + [ls,i,val] -> do + _ <- ensureEqualTy exp (VectorTy elty) ls + _ <- ensureEqualTy exp IntTy i + _ <- ensureEqualTy exp elty val + pure (VectorTy elty, tstate) + _ -> error $ "InplaceVUpdateP expects exactly 3 type arguments. Given: " ++ show tys + + VConcatP elty -> do + len1 + case tys of + [ls] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls + pure (VectorTy elty, tstate) + _ -> error $ "VConcatP expects exactly 2 type arguments. Given: " ++ show tys + + + -- Given that the first argument is a list of type (VectorTy t), + -- ensure that the 2nd argument is function reference of type: + -- ty -> ty -> Bool + VSortP elty -> + case (es !! 1) of + VarE f -> do + len2 + case tys of + [ls] -> do + let fn_ty = lookupFEnvLocVar (fromVarToFreeVarsTy f) env + in_tys = inTys fn_ty + ret_ty = outTy fn_ty + err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + case in_tys of + [a,b] -> do + _ <- ensureEqualTy (es !! 1) a elty + _ <- ensureEqualTy (es !! 1) b elty + _ <- ensureEqualTy (es !! 1) ret_ty IntTy + pure (VectorTy elty, tstate) + _ -> err fn_ty + _ -> error $ "VSortP expects exactly 1 type argument. Given: " ++ show tys + oth -> throwError $ GenericTC ("vsort: function pointer has to be a variable reference. Got"++ sdoc oth) exp + + InplaceVSortP elty -> recur tstatein (PrimAppE (VSortP elty) es) + + VMergeP elty -> do + len2 + checkListElemTy elty + case tys of + [ls1,ls2] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 + _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 + pure (VectorTy elty, tstate) + _ -> error $ "VMergeP expects exactly 2 type arguments. Given: " ++ show tys + + PDictInsertP kty vty -> do + len3 + checkListElemTy kty + checkListElemTy vty + case tys of + [key, val, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 1) val vty + _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) + pure (PDictTy kty vty, tstate) + _ -> error $ "PDictInsertP expects exactly 3 type arguments. Given: " ++ show tys + + PDictLookupP kty vty -> do + len2 + checkListElemTy kty + checkListElemTy vty + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 1) dict (PDictTy kty vty) + pure (vty, tstate) + _ -> error $ "PDictLookupP expects exactly 2 type arguments. Given: " ++ show tys + + PDictAllocP kty vty -> do + len0 + checkListElemTy kty + checkListElemTy vty + pure (PDictTy kty vty, tstate) + + PDictHasKeyP kty vty -> do + len2 + checkListElemTy kty + checkListElemTy vty + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 1) dict (PDictTy kty vty) + pure (BoolTy, tstate) + _ -> error $ "PDictHasKeyP expects exactly 2 type arguments. Given: " ++ show tys + + PDictForkP kty vty -> do + len1 + checkListElemTy kty + checkListElemTy vty + case tys of + [dict] -> do + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (ProdTy [PDictTy kty vty, PDictTy kty vty], tstate) + _ -> error $ "PDictForkP expects exactly 1 type argument. Given: " ++ show tys + + PDictJoinP kty vty -> do + len2 + checkListElemTy kty + checkListElemTy vty + case tys of + [dict1, dict2] -> do + _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) + _ <- ensureEqualTy (es !! 1) dict2 (PDictTy kty vty) + pure (PDictTy kty vty, tstate) + _ -> error $ "PDictJoinP expects exactly 2 type arguments. Given: " ++ show tys + + LLAllocP elty -> do + len0 + checkListElemTy elty + pure (ListTy elty, tstate) + + LLIsEmptyP elty -> do + len1 + checkListElemTy elty + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (BoolTy, tstate) + _ -> error $ "LLIsEmptyP expects exactly 1 type argument. Given: " ++ show tys + + LLConsP elty -> do + len2 + checkListElemTy elty + case tys of + [elt, ll] -> do + _ <- ensureEqualTy (es !! 0) elt elty + _ <- ensureEqualTy (es !! 1) ll (ListTy elty) + pure (ListTy elty, tstate) + _ -> error $ "LLConsP expects exactly 2 type arguments. Given: " ++ show tys + + LLHeadP elty -> do + len1 + checkListElemTy elty + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (elty, tstate) + _ -> error $ "LLHeadP expects exactly 1 type argument. Given: " ++ show tys + + LLTailP elty -> do + len1 + checkListElemTy elty + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (ListTy elty, tstate) + _ -> error $ "LLTailP expects exactly 1 type argument. Given: " ++ show tys + + LLFreeP elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy [], tstate) + _ -> error $ "LLFreeP expects exactly 1 type argument. Given: " ++ show tys + + LLFree2P elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy [], tstate) + _ -> error $ "LLFree2P expects exactly 1 type argument. Given: " ++ show tys + + LLCopyP elty -> do + len1 + checkListElemTy elty + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ListTy elty, tstate) + _ -> error $ "LLCopyP expects exactly 1 type argument. Given: " ++ show tys + + GetNumProcessors -> do + len0 + pure (IntTy, tstate) + + PrintInt -> do + len1 + _ <- ensureEqualTy (es !!! 0) IntTy (tys !!! 0) + pure (ProdTy [], tstate) + + PrintChar -> do + len1 + _ <- ensureEqualTy (es !!! 0) CharTy (tys !!! 0) + pure (ProdTy [], tstate) + + PrintFloat -> do + len1 + _ <- ensureEqualTy (es !!! 0) FloatTy (tys !!! 0) + pure (ProdTy [], tstate) + + PrintBool -> do + len1 + _ <- ensureEqualTy (es !!! 0) BoolTy (tys !!! 0) + pure (ProdTy [], tstate) + + PrintSym -> do + len1 + _ <- ensureEqualTy (es !!! 0) SymTy (tys !!! 0) + pure (ProdTy [], tstate) + + ReadInt -> throwError $ GenericTC "ReadInt not handled" exp + + SymSetEmpty -> do + len0 + pure (SymSetTy, tstate) + + SymSetInsert -> do + len2 + _ <- ensureEqualTy (es !!! 0) SymSetTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + pure (SymSetTy, tstate) + + SymSetContains -> do + len2 + _ <- ensureEqualTy (es !!! 0) SymSetTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + pure (BoolTy, tstate) + + SymHashEmpty -> do + len0 + pure (SymHashTy, tstate) + + SymHashInsert -> do + len3 + _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + _ <- ensureEqualTy (es !!! 2) SymTy (tys !!! 2) + pure (SymHashTy, tstate) + + SymHashLookup -> do + len2 + _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + pure (SymTy, tstate) + + SymHashContains -> do + len2 + _ <- ensureEqualTy (es !!! 0) SymHashTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + pure (BoolTy, tstate) + + IntHashEmpty -> do + len0 + pure (IntHashTy, tstate) + + IntHashInsert -> do + len3 + _ <- ensureEqualTy (es !!! 0) IntHashTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + _ <- ensureEqualTy (es !!! 2) IntTy (tys !!! 2) + pure (IntHashTy, tstate) + + IntHashLookup -> do + len2 + _ <- ensureEqualTy (es !!! 0) IntHashTy (tys !!! 0) + _ <- ensureEqualTy (es !!! 1) SymTy (tys !!! 1) + pure (IntTy, tstate) + + Write3dPpmFile{} -> throwError $ GenericTC "Write3dPpmFile not handled yet" exp + + RequestEndOf{} -> throwError $ GenericTC "tcExp of PrimAppE: RequestEndOf not handled yet" exp LetE (v, _ls, ty, e1@(AppE _f _ls1 _)) e2 -> do (ty1,tstate1) <- recur tstatein e1 @@ -887,9 +944,11 @@ tcExp ddfs env funs constrs regs tstatein exp = -- get the region of the SoA loc. r <- getRegion exp constrs soa_loc -- get the region of the field location - let Just r' = case r of - SoAR _dreg fieldRegions -> lookup key fieldRegions - _ -> error $ "L2.Typecheck.tcExp: GetFieldLocSoA: Expected SoAR region, got " ++ show r + r' <- case r of + SoAR _dreg fieldRegions -> case lookup key fieldRegions of + Just region -> return region + Nothing -> error $ "L2.Typecheck.tcExp: Key not found in fieldRegions: " ++ show key + _ -> error $ "L2.Typecheck.tcExp: GetFieldLocSoA: Expected SoAR region, got " ++ show r let tstate1 = extendTS loc (Output, True) $ tstatein let constrs1 = extendConstrs (InRegionC loc r') $ constrs (ty, tstate2) <- tcExp ddfs env' funs constrs1 regs tstate1 e diff --git a/gibbon-compiler/src/Gibbon/L3/Typecheck.hs b/gibbon-compiler/src/Gibbon/L3/Typecheck.hs index 241dea6bd..dc9d3bf96 100644 --- a/gibbon-compiler/src/Gibbon/L3/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L3/Typecheck.hs @@ -425,10 +425,12 @@ tcExp isSoA isPacked ddfs env exp = do IsBig -> do len2 - let [ity, ety] = tys - ensureEqualTy exp ity IntTy - ensureEqualTy exp ety CursorTy - pure BoolTy + case tys of + [ity, ety] -> do + ensureEqualTy exp ity IntTy + ensureEqualTy exp ety CursorTy + pure BoolTy + _ -> error $ "Expected exactly two type arguments in IsBig, got: " ++ show tys PrintInt -> do len1 @@ -500,32 +502,44 @@ tcExp isSoA isPacked ddfs env exp = do DictEmptyP _ty -> do len1 - let [a] = tys + let a = case tys of + [a'] -> a' + _ -> error $ "DictEmptyP expects exactly 1 type argument, got " ++ show tys _ <- ensureEqualTyModCursor isSoA exp ArenaTy a - let (VarE var) = es !! 0 + let var = case es !! 0 of + VarE v -> v + other -> error $ "DictEmptyP expects a variable expression, got " ++ show other return $ SymDictTy (Just var) CursorTy DictInsertP _ty -> do len4 - let [a,_d,k,v] = tys - let (VarE var) = es !! 0 - _ <- ensureEqualTyModCursor isSoA exp ArenaTy a - _ <- ensureEqualTyModCursor isSoA exp SymTy k - _ <- ensureEqualTyModCursor isSoA exp CursorTy v - return $ SymDictTy (Just var) CursorTy + case tys of + [a,_d,k,v] -> + case es !! 0 of + VarE var -> do + _ <- ensureEqualTyModCursor isSoA exp ArenaTy a + _ <- ensureEqualTyModCursor isSoA exp SymTy k + _ <- ensureEqualTyModCursor isSoA exp CursorTy v + return $ SymDictTy (Just var) CursorTy + other -> error $ "DictInsertP expects a variable expression, got " ++ show other + _ -> error $ "DictInsertP expects 4 types, got " ++ show tys DictLookupP _ty -> do len2 - let [_d,k] = tys - _ <- ensureEqualTyModCursor isSoA exp SymTy k - return CursorTy + case tys of + [_d,k] -> do + _ <- ensureEqualTyModCursor isSoA exp SymTy k + return CursorTy + _ -> error $ "DictLookupP expects 2 types, got " ++ show tys DictHasKeyP _ty -> do len2 - let [_d,k] = tys - -- _ <- ensureEqualTyNoLoc exp (SymDictTy ty) d - _ <- ensureEqualTyModCursor isSoA exp SymTy k - return BoolTy + case tys of + [_d,k] -> do + -- _ <- ensureEqualTyNoLoc exp (SymDictTy ty) d + _ <- ensureEqualTyModCursor isSoA exp SymTy k + return BoolTy + _ -> error $ "DictHasKeyP expects 2 types, got " ++ show tys ErrorP _str ty -> do len0 @@ -540,9 +554,11 @@ tcExp isSoA isPacked ddfs env exp = do WritePackedFile _ ty | PackedTy{} <- ty -> do len1 - let [packed_ty] = tys - _ <- ensureEqualTyModCursor isSoA exp packed_ty ty - pure (ProdTy []) + case tys of + [packed_ty] -> do + _ <- ensureEqualTyModCursor isSoA exp packed_ty ty + pure (ProdTy []) + _ -> error $ "WritePackedFile expects one type, got " ++ show tys | otherwise -> error $ "writePackedFile expects a packed type. Given" ++ sdoc ty ReadArrayFile _ ty -> do @@ -556,63 +572,80 @@ tcExp isSoA isPacked ddfs env exp = do VAllocP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) IntTy i - pure (VectorTy elty) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) IntTy i + pure (VectorTy elty) + _ -> error $ "VAllocPP expects one type, got " ++ show tys + VFreeP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy []) + _ -> error $ "VFreeP expects one type, got " ++ show tys VFree2P elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) i + pure (ProdTy []) + _ -> error $ "VFree2P expects one type, got " ++ show tys VLengthP elty -> do len1 checkListElemTy elty - let [ls] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - pure IntTy + case tys of + [ls] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + pure IntTy + _ -> error $ "VLengthP expects one type, got " ++ show tys VNthP elty -> do len2 checkListElemTy elty - let [ls, i] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - _ <- ensureEqualTy (es !! 1) IntTy i - pure elty + case tys of + [ls, i] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + _ <- ensureEqualTy (es !! 1) IntTy i + pure elty + _ -> error $ "VNthP expects two types, got " ++ show tys VSliceP elty -> do len3 checkListElemTy elty - let [from,to,ls] = tys - _ <- ensureEqualTy (es !! 0) IntTy from - _ <- ensureEqualTy (es !! 1) IntTy to - _ <- ensureEqualTy (es !! 2) (VectorTy elty) ls - pure (VectorTy elty) + case tys of + [from,to,ls] -> do + _ <- ensureEqualTy (es !! 0) IntTy from + _ <- ensureEqualTy (es !! 1) IntTy to + _ <- ensureEqualTy (es !! 2) (VectorTy elty) ls + pure (VectorTy elty) + _ -> error $ "VSliceP expects three types, got " ++ show tys InplaceVUpdateP elty -> do len3 checkListElemTy elty - let [ls,i,x] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - _ <- ensureEqualTy (es !! 1) IntTy i - _ <- ensureEqualTy (es !! 2) elty x - pure (VectorTy elty) + case tys of + [ls,i,x] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + _ <- ensureEqualTy (es !! 1) IntTy i + _ <- ensureEqualTy (es !! 2) elty x + pure (VectorTy elty) + _ -> error $ "InplaceVUpdateP expects three types, got " ++ show tys VConcatP elty -> do len1 checkListElemTy elty - let [ls] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls - pure (VectorTy elty) + case tys of + [ls] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy (VectorTy elty)) ls + pure (VectorTy elty) + _ -> error $ "VConcatP expects one type, got " ++ show tys -- Given that the first argument is a list of type (VectorTy t), -- ensure that the 2nd argument is function reference of type: @@ -621,17 +654,19 @@ tcExp isSoA isPacked ddfs env exp = do case (es !! 1) of VarE f -> do len2 - let [ls] = tys - fn_ty@(in_tys, ret_ty) = lookupFEnv f env - err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls - case in_tys of - [a,b] -> do - _ <- ensureEqualTy (es !! 1) a elty - _ <- ensureEqualTy (es !! 1) b elty - _ <- ensureEqualTy (es !! 1) ret_ty IntTy - pure (VectorTy elty) - _ -> err fn_ty + case tys of + [ls] -> do + let fn_ty@(in_tys, ret_ty) = lookupFEnv f env + err x = throwError $ GenericTC ("vsort: Expected a sort function of type (ty -> ty -> Bool). Got"++ sdoc x) exp + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls + case in_tys of + [a,b] -> do + _ <- ensureEqualTy (es !! 1) a elty + _ <- ensureEqualTy (es !! 1) b elty + _ <- ensureEqualTy (es !! 1) ret_ty IntTy + pure (VectorTy elty) + _ -> err fn_ty + _ -> error $ "VSortP expects one type, got " ++ show tys oth -> throwError $ GenericTC ("vsort: function pointer has to be a variable reference. Got"++ sdoc oth) exp InplaceVSortP elty -> go (PrimAppE (VSortP elty) es) @@ -639,29 +674,35 @@ tcExp isSoA isPacked ddfs env exp = do VMergeP elty -> do len2 checkListElemTy elty - let [ls1,ls2] = tys - _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 - _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 - pure (VectorTy elty) + case tys of + [ls1,ls2] -> do + _ <- ensureEqualTy (es !! 0) (VectorTy elty) ls1 + _ <- ensureEqualTy (es !! 1) (VectorTy elty) ls2 + pure (VectorTy elty) + _ -> error $ "VMergeP expects two types, got " ++ show tys PDictInsertP kty vty -> do len3 checkListElemTy kty checkListElemTy vty - let [key, val, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 1) val vty - _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) - pure (PDictTy kty vty) + case tys of + [key, val, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 1) val vty + _ <- ensureEqualTy (es !! 2) dict (PDictTy kty vty) + pure (PDictTy kty vty) + _ -> error $ "PDictInsertP expects three types, got " ++ show tys PDictLookupP kty vty -> do len2 checkListElemTy kty checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (vty) + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (vty) + _ -> error $ "PDictlookupP expects two types, got " ++ show tys PDictAllocP kty vty -> do len0 @@ -673,27 +714,33 @@ tcExp isSoA isPacked ddfs env exp = do len2 checkListElemTy kty checkListElemTy vty - let [key, dict] = tys - _ <- ensureEqualTy (es !! 0) key kty - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (BoolTy) + case tys of + [key, dict] -> do + _ <- ensureEqualTy (es !! 0) key kty + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (BoolTy) + _ -> error $ "PDictHasKeyP expects two types, got " ++ show tys PDictForkP kty vty -> do len1 checkListElemTy kty checkListElemTy vty - let [dict] = tys - _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) - pure (ProdTy [PDictTy kty vty, PDictTy kty vty]) + case tys of + [dict] -> do + _ <- ensureEqualTy (es !! 0) dict (PDictTy kty vty) + pure (ProdTy [PDictTy kty vty, PDictTy kty vty]) + _ -> error $ "PDictForkP expects one type, got " ++ show tys PDictJoinP kty vty -> do len2 checkListElemTy kty checkListElemTy vty - let [dict1, dict2] = tys - _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) - _ <- ensureEqualTy (es !! 0) dict2 (PDictTy kty vty) - pure (PDictTy kty vty) + case tys of + [dict1, dict2] -> do + _ <- ensureEqualTy (es !! 0) dict1 (PDictTy kty vty) + _ <- ensureEqualTy (es !! 0) dict2 (PDictTy kty vty) + pure (PDictTy kty vty) + _ -> error $ "PDictJoinP expects two types, got " ++ show tys LLAllocP elty -> do len0 @@ -703,52 +750,66 @@ tcExp isSoA isPacked ddfs env exp = do LLIsEmptyP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (BoolTy) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (BoolTy) + _ -> error $ "LLIsEmptyP expects one type, got " ++ show tys LLConsP elty -> do len2 checkListElemTy elty - let [elt, ll] = tys - _ <- ensureEqualTy (es !! 0) elt elty - _ <- ensureEqualTy (es !! 1) ll (ListTy elty) - pure (ListTy elty) + case tys of + [elt, ll] -> do + _ <- ensureEqualTy (es !! 0) elt elty + _ <- ensureEqualTy (es !! 1) ll (ListTy elty) + pure (ListTy elty) + _ -> error $ "LLConsP expects two types, got " ++ show tys LLHeadP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (elty) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (elty) + _ -> error $ "LLHeadP expects one type, got " ++ show tys LLTailP elty -> do len1 checkListElemTy elty - let [ll] = tys - _ <- ensureEqualTy (es !! 0) ll (ListTy elty) - pure (ListTy elty) + case tys of + [ll] -> do + _ <- ensureEqualTy (es !! 0) ll (ListTy elty) + pure (ListTy elty) + _ -> error $ "LLTailP expects one type, got " ++ show tys LLFreeP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy []) + _ -> error $ "LLFreeP expects one type, got " ++ show tys LLFree2P elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ProdTy []) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ProdTy []) + _ -> error $ "LLFree2P expects one type, got " ++ show tys LLCopyP elty -> do len1 checkListElemTy elty - let [i] = tys - _ <- ensureEqualTy (es !! 0) (ListTy elty) i - pure (ListTy elty) + case tys of + [i] -> do + _ <- ensureEqualTy (es !! 0) (ListTy elty) i + pure (ListTy elty) + _ -> error $ "LLCopyP expects one type, got " ++ show tys GetNumProcessors -> do len0 diff --git a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs index 48662cbe9..7a3be2980 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs @@ -95,11 +95,17 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = (ewitnesses', locenv'') = foldr (\(witloc, tloc) (wits, env) -> - let (New.Loc lrem) = (env # (tloc)) - wit' = New.EndWitness lrem witloc - env' = M.insert witloc wit' env - in (wit' : wits, env')) + let val = (env # (tloc)) + lrem = case val of + New.Loc l -> l + _ -> error $ "Expected New.Loc, got: " ++ show val + wit' = New.EndWitness lrem witloc + env' = M.insert witloc wit' env + in (wit' : wits, env')) ([], locenv') + + + (zip ewitnesses traversed_locs) rhs' <- go locenv env2 rhs bod' <- go locenv'' (extendVEnv v ty env2) bod @@ -122,39 +128,50 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = CaseE scrt brs | VarE v <- scrt -> - do let (PackedTy _ scrt_loc) = lookupVEnv v env2 - (New.Loc lrem) = locenv # scrt_loc - - docase (dcon, vlocs, rhs) = do - - let mkLocArg loc (Just idx) = let lrem_reg = New.lremReg lrem - lrem_end_reg = New.lremEndReg lrem - New.Loc lrem' = case lrem_reg of - SingleR _ -> New.Loc $ lrem { New.lremLoc = loc } - SoARv _dcreg fregs -> case L.lookup (dcon, idx) fregs of - Just fr -> New.Loc $ lrem { New.lremLoc = loc, New.lremReg = fr } - Nothing -> New.Loc $ lrem { New.lremLoc = loc } - New.Loc lrem'' = case lrem_end_reg of - SingleR _ -> New.Loc lrem' - SoARv _dcreg fregs -> case L.lookup (dcon, idx) fregs of - Just fr -> New.Loc $ lrem' { New.lremEndReg = fr} - Nothing -> New.Loc lrem' - in New.Loc lrem'' - - mkLocArg loc Nothing = New.Loc $ lrem { New.lremLoc = loc } - let (vars,locs) = unzip vlocs - locargs = map (\(loc, idx) -> mkLocArg loc (Just idx)) $ zip locs [0..length(locs)] - vlocs' = zip vars locargs - locenv' = foldr - (\(New.Loc lrem') acc -> M.insert (New.lremLoc lrem') (New.Loc lrem') acc) - locenv locargs - env2' = extendPatternMatchEnv dcon ddefs vars locs env2 - locenv'' = if isRedirectionTag dcon || isIndirectionTag dcon - then let ptr = Single $ Sf.headErr vars - in M.insert ptr (mkLocArg ptr Nothing) locenv' - else locenv' - rhs' <- go locenv'' env2' rhs - dbgTrace minChatLvl "Print LREM Case: " dbgTrace minChatLvl (sdoc (lrem, locargs, locenv'')) dbgTrace minChatLvl "End LREM Case.\n" pure $ (dcon, vlocs', rhs') + + + do let scrt_loc = + case lookupVEnv v env2 of + PackedTy _ l -> l + other -> error $ "Expected PackedTy, got: " ++ show other + lrem = + case locenv # scrt_loc of + New.Loc l -> l + other -> error $ "Expected New.Loc, got: " ++ show other + docase (dcon, vlocs, rhs) = do + let mkLocArg loc (Just idx) = let lrem_reg = New.lremReg lrem + lrem_end_reg = New.lremEndReg lrem + lrem' = + case lrem_reg of + SingleR _ -> lrem { New.lremLoc = loc } + SoARv _dcreg fregs -> case L.lookup (dcon, idx) fregs of + Just fr -> lrem { New.lremLoc = loc, New.lremReg = fr } + Nothing -> lrem { New.lremLoc = loc } + lrem'' = + case lrem_end_reg of + SingleR _ -> lrem' + SoARv _dcreg fregs -> case L.lookup (dcon, idx) fregs of + Just fr -> lrem' { New.lremEndReg = fr} + Nothing -> lrem' + in New.Loc lrem'' + + mkLocArg loc Nothing = New.Loc $ lrem { New.lremLoc = loc } + let (vars,locs) = unzip vlocs + locargs = map (\(loc, idx) -> mkLocArg loc (Just idx)) $ zip locs [0..length(locs)] + vlocs' = zip vars locargs + locenv' = foldr + (\locv acc -> + case locv of + New.Loc lrem' -> M.insert (New.lremLoc lrem') (New.Loc lrem') acc + other -> error $ "Expected New.Loc in fromOldL2Exp, got: " ++ show other) + locenv locargs + env2' = extendPatternMatchEnv dcon ddefs vars locs env2 + locenv'' = if isRedirectionTag dcon || isIndirectionTag dcon + then let ptr = Single $ Sf.headErr vars + in M.insert ptr (mkLocArg ptr Nothing) locenv' + else locenv' + rhs' <- go locenv'' env2' rhs + dbgTrace minChatLvl "Print LREM Case: " dbgTrace minChatLvl (sdoc (lrem, locargs, locenv'')) dbgTrace minChatLvl "End LREM Case.\n" pure $ (dcon, vlocs', rhs') (CaseE (VarE v)) <$> mapM docase brs @@ -255,11 +272,13 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = case locexp of StartOfRegionLE reg -> New.Loc (New.LREM loc (regionToVar reg) (toEndVRegVar (regionToVar reg)) Output) AfterConstantLE _ loc2 -> - let (New.Loc lrem) = locenv0 # loc2 - in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) + case locenv0 # loc2 of + (New.Loc lrem) -> New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) + other -> error $ "Expected New.Loc in AfterConstantLE, got " ++ show other AfterVariableLE _ loc2 _ -> - let (New.Loc lrem) = locenv0 # loc2 - in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) + case locenv0 # loc2 of + (New.Loc lrem) -> New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) + other -> error $ "Expected New.Loc in AfterVariableLE, got " ++ show other InRegionLE reg -> New.Loc (New.LREM loc (regionToVar reg) (toEndVRegVar (regionToVar reg)) Output) FreeLE -> @@ -269,40 +288,48 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = New.Loc lrem -> New.Loc (lrem { New.lremLoc = loc }) New.EndWitness lrem _ -> New.Loc ( lrem { New.lremLoc = loc } ) oth -> error $ "toLocArg: got" ++ sdoc oth - GetDataConLocSoA loc2 -> - let (New.Loc lrem) = locenv0 # loc2 - regVar = New.lremReg lrem - endRegVar = New.lremEndReg lrem - modality = New.lremMode lrem - dcRegVar = getDataConRegFromRegVar regVar - dcEndRegVar = getDataConRegFromRegVar endRegVar - in New.Loc (New.LREM loc dcRegVar dcEndRegVar modality) + GetDataConLocSoA loc2 -> + case locenv0 # loc2 of + (New.Loc lrem) -> + let regVar = New.lremReg lrem + endRegVar = New.lremEndReg lrem + modality = New.lremMode lrem + dcRegVar = getDataConRegFromRegVar regVar + dcEndRegVar = getDataConRegFromRegVar endRegVar + in New.Loc (New.LREM loc dcRegVar dcEndRegVar modality) + other -> error $ "Expected New.Loc in GetDataConLocSoA, got " ++ show other GetFieldLocSoA (dcon, idx) loc2 -> - let (New.Loc lrem) = locenv0 # loc2 - regVar = New.lremReg lrem - endRegVar = New.lremEndReg lrem - modality = New.lremMode lrem - fieldRegVar = getFieldRegFromRegVar (dcon, idx) regVar - fieldEndRegVar = getFieldRegFromRegVar (dcon, idx) endRegVar - in New.Loc (New.LREM loc fieldRegVar fieldEndRegVar modality) + case locenv0 # loc2 of + (New.Loc lrem) -> + let regVar = New.lremReg lrem + endRegVar = New.lremEndReg lrem + modality = New.lremMode lrem + fieldRegVar = getFieldRegFromRegVar (dcon, idx) regVar + fieldEndRegVar = getFieldRegFromRegVar (dcon, idx) endRegVar + in New.Loc (New.LREM loc fieldRegVar fieldEndRegVar modality) + other -> error $ "Expected New.Loc in GetFieldLocSoA, got " ++ show other GenSoALoc dloc fieldsLocs -> -- Get the single locs and build this part let _soa_loc = SoA (unwrapLocVar dloc) (map (\(d, flc) -> (d, flc)) fieldsLocs) - (New.Loc dlrem) = locenv0 # dloc - dloc_reg = New.lremReg dlrem - dloc_end_reg = New.lremEndReg dlrem - field_regs = map (\(k, flc) -> let (New.Loc flrem) = locenv0 # flc - in (k, New.lremReg flrem) - ) fieldsLocs - field_end_regs = map (\(k, flc) -> let (New.Loc flrem) = locenv0 # flc - in (k, New.lremEndReg flrem) - ) fieldsLocs - soa_reg = SoARv dloc_reg field_regs - soa_end_reg = SoARv dloc_end_reg field_end_regs - -- modality of all regions should be same - modality = New.lremMode dlrem - lrem = New.LREM loc soa_reg soa_end_reg modality - in New.Loc lrem + lrem = case locenv0 # dloc of + New.Loc dlrem -> + let dloc_reg = New.lremReg dlrem + dloc_end_reg = New.lremEndReg dlrem + field_regs = map (\(k, flc) -> case locenv0 # flc of + New.Loc flrem -> (k, New.lremReg flrem) + other -> error $ "Expected New.Loc for field, got " ++ show other + ) fieldsLocs + field_end_regs = map (\(k, flc) -> case locenv0 # flc of + New.Loc flrem -> (k, New.lremEndReg flrem) + other -> error $ "Expected New.Loc for field end, got " ++ show other + ) fieldsLocs + soa_reg = SoARv dloc_reg field_regs + soa_end_reg = SoARv dloc_end_reg field_end_regs + -- modality of all regions should be same + modality = New.lremMode dlrem + in New.LREM loc soa_reg soa_end_reg modality + other -> error $ "Expected New.Loc for SoA loc, got " ++ show other + in New.Loc lrem AssignLE {} -> error "toLocArg: AssignLE not handled" diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index a4ad8b292..1346edc58 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -446,8 +446,10 @@ revertExp ex = AppE v _ args -> AppE v [] (L.map revertExp args) PrimAppE p args -> PrimAppE (revertPrim p) $ L.map revertExp args LetE (v,_, ty, (Ext (Old.IndirectionE _ _ _ _ arg))) bod -> - let PackedTy tycon _ = unTy2 ty in + case unTy2 ty of + PackedTy tycon _ -> LetE (v,[],(stripTyLocs (unTy2 ty)), AppE (mkCopyFunName tycon) [] [revertExp arg]) (revertExp bod) + otherTy -> error $ "Expected PackedTy in revertExp, got " ++ show otherTy LetE (v,_,ty,rhs) bod -> LetE (v,[], stripTyLocs (unTy2 ty), revertExp rhs) (revertExp bod) IfE a b c -> IfE (revertExp a) (revertExp b) (revertExp c) diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index 8e198def4..2722a93d5 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} module Gibbon.Passes.AddRAN diff --git a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs index d9b912299..79e5c9898 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs @@ -62,10 +62,11 @@ addTraversalsExp :: DDefs Ty2 -> FunDefs2 -> Env2 Var Ty2 -> RegEnv -> String -> addTraversalsExp ddefs fundefs env2 renv context ex = case ex of CaseE scrt@(VarE sv) brs -> do - let PackedTy _tycon tyloc = lookupVEnv sv env2 - reg = renv # tyloc - CaseE scrt <$> mapM (docase reg) brs - + case lookupVEnv sv env2 of + PackedTy _tycon tyloc -> do + let reg = renv # tyloc + CaseE scrt <$> mapM (docase reg) brs + otherTy -> error $ "addTraversalsExp: expected PackedTy for variable " ++ show sv ++ ", but got: " ++ show otherTy CaseE scrt _ -> error $ "addTraversalsExp: Scrutinee is not flat " ++ sdoc scrt -- standard recursion here diff --git a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs index cd0bf25af..75f700d67 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Codegen.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Codegen.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -Wno-type-defaults #-} {-# LANGUAGE ParallelListComp #-} @@ -1568,12 +1569,14 @@ codegenTail venv fenv sort_fns (LetPrimCallT bnds prm rnds body) ty sync_deps = -- [ C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = $(codegenTriv venv pleft) + $(codegenTriv venv pright); |] ] CastPtr -> do - let [(outV, outT)] = bnds - [ptr] = rnds - ptr' = codegenTriv venv ptr - return [ C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($ty:(codegenTy outT)) $exp:ptr'; |] ] - - + case (bnds, rnds) of + ([(outV, outT)], [ptr]) -> do + let ptr' = codegenTriv venv ptr + return [ C.BlockDecl [cdecl| $ty:(codegenTy outT) $id:outV = ($ty:(codegenTy outT)) $exp:ptr'; |] ] + _ -> + error $ "CastPtr: expected one binding and one operand, got " + ++ show (length bnds) ++ " bindings and " + ++ show (length rnds) ++ " operands." return $ pre ++ bod' diff --git a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs index 045797159..ff819e199 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} diff --git a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs index d78e980f3..c99c80e72 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs @@ -32,75 +32,84 @@ followPtrs (Prog ddefs fundefs mainExp) = do go env out_ty funName funArgs funTy e = case e of CaseE scrt brs -> do - let VarE scrtv = scrt - PackedTy tycon scrt_loc = env # scrtv - DDef{dataCons} = lookupDDef ddefs tycon - flags <- getDynFlags - let no_copies = gopt Opt_No_RemoveCopies flags - if no_copies - then do - indir_ptrv <- gensym "indr" - _indir_ptrv_loc <- freshCommonLoc "indr" scrt_loc - callv <- gensym "call" - wc <- gensym "wildcard" - indir_ptrloc <- freshCommonLoc "case" scrt_loc + case scrt of + VarE scrtv -> do + case env # scrtv of + PackedTy tycon scrt_loc -> do + let DDef{dataCons} = lookupDDef ddefs tycon + flags <- getDynFlags + let no_copies = gopt Opt_No_RemoveCopies flags + if no_copies + then do + indir_ptrv <- gensym "indr" + _indir_ptrv_loc <- freshCommonLoc "indr" scrt_loc + callv <- gensym "call" + wc <- gensym "wildcard" + indir_ptrloc <- freshCommonLoc "case" scrt_loc - endofs <- mapM (\lr -> case lr of - EndOf lrm -> do - let loc = lrmLoc lrm - freshCommonLoc "endof" loc - ) (locRets funTy) + endofs <- mapM (\lr -> case lr of + EndOf lrm -> do + let loc = lrmLoc lrm + freshCommonLoc "endof" loc + ) (locRets funTy) + + --endofs <- mapM (\_ -> gensym "endof") (locRets funTy) + --let endofs' = map Single endofs + let args = foldr (\v acc -> if v == scrtv + then ((VarE indir_ptrv) : acc) + else (VarE v : acc)) + [] funArgs + let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((indir_ptrloc) : acc) else (loc : acc)) [] (inLocVars funTy) + let out_locs = outLocVars funTy + let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons + let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $ + LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $ + Ext (RetE endofs callv) + let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod) + ---------------------------------------- + (pure (CaseE scrt (brs ++ [redir_br]))) + else do + indir_ptrv <- gensym "indr" + indir_ptrloc <- gensym "case" + jump <- gensym "jump" + callv <- gensym "call" + let _effs = arrEffs funTy + endofs <- mapM (\_ -> gensym "endof") (locRets funTy) + let endofs' = map Single endofs + let ret_endofs = foldr (\(end, (EndOf (LRM loc _ _))) acc -> + if loc == scrt_loc + then (Single jump) : acc + else end : acc) + [] + (zip endofs' (locRets funTy)) + let args = foldr (\v acc -> if v == scrtv + then ((VarE indir_ptrv) : acc) + else (VarE v : acc)) + [] funArgs + let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((Single indir_ptrv) : acc) else (loc : acc)) [] (inLocVars funTy) + let out_locs = outLocVars funTy + wc <- gensym "wildcard" + let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 (Single indir_ptrloc)) $ + (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $ + LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ + Ext (RetE ret_endofs callv) + let indir_dcon = fst $ fromJust $ L.find (isIndirectionTag . fst) dataCons + let indir_br = (indir_dcon,[(indir_ptrv,(Single indir_ptrloc))],indir_bod) + ---------------------------------------- + let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons + let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $ + LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ + Ext (RetE endofs' callv) + let redir_br = (redir_dcon,[(indir_ptrv,(Single indir_ptrloc))],redir_bod) + ---------------------------------------- + (pure (CaseE scrt (brs ++ [indir_br,redir_br]))) + other -> + error $ "followPtrs: expected packed type for " ++ show scrtv + ++ ", but got " ++ show other + other -> + error $ "followPtrs: expected variable expression for " ++ show scrt + ++ ", but got " ++ show other - --endofs <- mapM (\_ -> gensym "endof") (locRets funTy) - --let endofs' = map Single endofs - let args = foldr (\v acc -> if v == scrtv - then ((VarE indir_ptrv) : acc) - else (VarE v : acc)) - [] funArgs - let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((indir_ptrloc) : acc) else (loc : acc)) [] (inLocVars funTy) - let out_locs = outLocVars funTy - let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons - let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $ - LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $ - Ext (RetE endofs callv) - let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod) - ---------------------------------------- - (pure (CaseE scrt (brs ++ [redir_br]))) - else do - indir_ptrv <- gensym "indr" - indir_ptrloc <- gensym "case" - jump <- gensym "jump" - callv <- gensym "call" - let _effs = arrEffs funTy - endofs <- mapM (\_ -> gensym "endof") (locRets funTy) - let endofs' = map Single endofs - let ret_endofs = foldr (\(end, (EndOf (LRM loc _ _))) acc -> - if loc == scrt_loc - then (Single jump) : acc - else end : acc) - [] - (zip endofs' (locRets funTy)) - let args = foldr (\v acc -> if v == scrtv - then ((VarE indir_ptrv) : acc) - else (VarE v : acc)) - [] funArgs - let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((Single indir_ptrv) : acc) else (loc : acc)) [] (inLocVars funTy) - let out_locs = outLocVars funTy - wc <- gensym "wildcard" - let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 (Single indir_ptrloc)) $ - (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $ - LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ - Ext (RetE ret_endofs callv) - let indir_dcon = fst $ fromJust $ L.find (isIndirectionTag . fst) dataCons - let indir_br = (indir_dcon,[(indir_ptrv,(Single indir_ptrloc))],indir_bod) - ---------------------------------------- - let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons - let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $ - LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ - Ext (RetE endofs' callv) - let redir_br = (redir_dcon,[(indir_ptrv,(Single indir_ptrloc))],redir_bod) - ---------------------------------------- - (pure (CaseE scrt (brs ++ [indir_br,redir_br]))) IfE a b c -> do a' <- go env out_ty funName funArgs funTy a b' <- go env out_ty funName funArgs funTy b diff --git a/gibbon-compiler/src/Gibbon/Passes/Freshen.hs b/gibbon-compiler/src/Gibbon/Passes/Freshen.hs index f19b72d27..c6e35a3c8 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Freshen.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Freshen.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index dd0fa07f2..ebcd51827 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-matches #-} {-# LANGUAGE BlockArguments #-} @@ -2819,9 +2820,11 @@ copyOutOfOrderPacked prg@(Prog ddfs fndefs mnExp) = do Nothing -> acc3 Just ls -> let binds = map (\(old,new) -> - let PackedTy tycon _ = L1.lookupVEnv old env2' - f = mkCopyFunName tycon - in (new,[],PackedTy tycon (),AppE f [] [VarE old])) + case L1.lookupVEnv old env2' of + PackedTy tycon _ -> + let f = mkCopyFunName tycon + in (new,[],PackedTy tycon (),AppE f [] [VarE old]) + otherTy -> error $ "copyOutOfOrderPacked.go: expected PackedTy for " ++ show old ++ ", but got " ++ show otherTy) ls in mkLets binds rhs1) rhs1 vars @@ -2829,7 +2832,6 @@ copyOutOfOrderPacked prg@(Prog ddfs fndefs mnExp) = do (cpy_env2, ls1) <- F.foldrM doPat (cpy_env1, []) ls pure $ (cpy_env2, CaseE scrt1 ls1) - ---------------------------------------- VarE{} -> pure (cpy_env, ex) diff --git a/gibbon-compiler/src/Gibbon/Passes/Lower.hs b/gibbon-compiler/src/Gibbon/Passes/Lower.hs index 7678aa11f..04e790501 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Lower.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Lower.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -248,15 +249,16 @@ printTy pkd ty trvs = -- This is reasonable because the AST is always flattened before -- we try to lower it. -- But we should change this to use gensym anyways.. - let T.VarTriv v = one - unpkd = varAppend "unpkd_" v - ignre = varAppend "ignre_" v - in - if pkd - then (\tl -> T.LetCallT False [(unpkd, T.PtrTy), (ignre, T.CursorTy)] - (mkUnpackerName constr) trvs $ - T.LetCallT False [] (mkPrinterName constr) [T.VarTriv unpkd] tl) - else T.LetCallT False [] (mkPrinterName constr) trvs + case one of + T.VarTriv v -> do + let unpkd = varAppend "unpkd_" v + ignre = varAppend "ignre_" v + if pkd + then (\tl -> T.LetCallT False [(unpkd, T.PtrTy), (ignre, T.CursorTy)] + (mkUnpackerName constr) trvs $ + T.LetCallT False [] (mkPrinterName constr) [T.VarTriv unpkd] tl) + else T.LetCallT False [] (mkPrinterName constr) trvs + _ -> error $ "Expected VarTriv, got: " ++ show one (VectorTy{}, [_one]) -> T.LetPrimCallT [] (T.PrintString "") [] (ListTy{}, [_one]) -> T.LetPrimCallT [] (T.PrintString "") [] diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 5b3c5f9a6..c6f2834d2 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-| Do all things necessary to compile parallel allocations to a single region. diff --git a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs index dfe8eff97..fc79904c1 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -- | Replace calls to copy functions with tagged indirection nodes module Gibbon.Passes.RemoveCopies where diff --git a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs index 61a7d3864..c47376135 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# LANGUAGE RecordWildCards #-} diff --git a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs index 8c4780339..c6f8bde4e 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unused-binds #-} diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs index 943c616f9..5dc85a9b1 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} module Gibbon.Passes.ThreadRegions where diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions2.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions2.hs index 0c5114d81..8d31ebdf6 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions2.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions2.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-unused-local-binds #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} diff --git a/gibbon-compiler/src/Gibbon/Passes/Unariser.hs b/gibbon-compiler/src/Gibbon/Passes/Unariser.hs index 343101a42..f38f5d42d 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Unariser.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Unariser.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Gibbon.Passes.Unariser (unariser, unariserExp) where diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 19c58f5ac..e30da6e36 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/gibbon-compiler/src/Gibbon/SExpFrontend.hs b/gibbon-compiler/src/Gibbon/SExpFrontend.hs index ff934b66c..687ecd56d 100644 --- a/gibbon-compiler/src/Gibbon/SExpFrontend.hs +++ b/gibbon-compiler/src/Gibbon/SExpFrontend.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/gibbon-rts/Makefile b/gibbon-rts/Makefile index 90a81921f..a3d42c2a0 100644 --- a/gibbon-rts/Makefile +++ b/gibbon-rts/Makefile @@ -150,7 +150,7 @@ $(C_RTS_DIR)/$(NAME).o: FORCE $(BUILD_DIR)/%.h: $(C_RTS_DIR)/%.h mkdir -p $(BUILD_DIR) && \ - ln -s $^ $@ + ln -sf $^ $@ $(BUILD_DIR): mkdir -p $(BUILD_DIR)