~jojo/Carth

31d7c4aec6da89ade53a335988703174801b8325 — JoJo 1 year, 3 months ago f86719e
Add skeleton module Optimize between Monomorphize & Compile
M TODO.org => TODO.org +14 -0
@@ 513,6 513,20 @@ Features and other stuff to do/implement in/around Carth.
   5. ???
   6. Profit.

** Sketch 2
   Maybe do the flattening thing so there is only one zero sized type,
   but don't optimize away operations returning Unit completely. It
   would still be nice to be able to expect side effects and panics to
   happen. Also, RealWorld wouldn't have to have a size and actually
   impact performance.

   Just flatten all ZSTs to the single ZST (Unit?); remove ZST
   variables (replace ZST var lookup w Unit literal); perform function
   applications, if, & fun pretty much as normal; in let, don't
   actually store the unit. Just compute the RHS; match is mostly
   unaffected I think?; constructions of ZSTs become nested
   seq:s. Yeah, I think that's it.

* TODO Pair notation
  ~(Pair _ _)~ sucks to type, and pairs are or will be common. An idea:


M app/Main.hs => app/Main.hs +6 -3
@@ 15,7 15,8 @@ import Conf
import GetConfig
import Compile
import Monomorphize
import qualified Monomorphic
import Optimize
import qualified Optimized as Ast
import qualified Parse
import EnvVars



@@ 48,7 49,7 @@ runFile cfg = do
    run f cfg mon
    putStrLn ""

frontend :: Config cfg => cfg -> FilePath -> IO Monomorphic.Program
frontend :: Config cfg => cfg -> FilePath -> IO Ast.Program
frontend cfg f = do
    let d = getDebug cfg
    verbose cfg ("   Parsing")


@@ 60,7 61,9 @@ frontend cfg f = do
    verbose cfg ("   Monomorphizing")
    let mon = monomorphize ann
    when d $ writeFile ".dbg.mono" (show mon)
    pure mon
    let opt = optimize mon
    when d $ writeFile ".dbg.opt" (show opt)
    pure opt

parse :: FilePath -> IO Parsed.Program
parse f = Parse.parse f >>= \case

M carth.cabal => carth.cabal +2 -0
@@ 38,6 38,8 @@ library
      Misc
      Monomorphic
      Monomorphize
      Optimize
      Optimized
      Parse
      Parsed
      Pretty

M src/Codegen.hs => src/Codegen.hs +10 -10
@@ 33,8 33,8 @@ import Lens.Micro.Platform (use, assign, Lens')
import Misc
import SrcPos
import FreeVars
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import qualified Optimized as Ast
import Optimized hiding (Type, Const)
import TypeAst
import Selections
import Gen


@@ 102,7 102,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) = runExcept $ 
    withGlobDefSigs
        :: MonadReader Env m
        => Lens' Env (Map TypedVar Operand)
        -> [(TypedVar, WithPos ([M.Type], e))]
        -> [(TypedVar, WithPos ([Ast.Type], e))]
        -> m x
        -> m x
    withGlobDefSigs env sigs ga = do


@@ 281,13 281,13 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Sizeof t -> (VLocal . litI64 . fromIntegral) <$> ((lift . sizeof) =<< genType t)
        Absurd t -> fmap (VLocal . undef) (genType t)

genExprLambda :: TypedVar -> (Expr, M.Type) -> Gen Val
genExprLambda :: TypedVar -> (Expr, Ast.Type) -> Gen Val
genExprLambda p (b, bt) = do
    fvXs <- lambdaBodyFreeVars p b
    bt' <- genRetType bt
    genLambda fvXs p (genTailExpr b, bt')

genConst :: M.Const -> Gen Val
genConst :: Ast.Const -> Gen Val
genConst = \case
    Int n -> pure (VLocal (litI64 n))
    F64 x -> pure (VLocal (litF64 x))


@@ 451,9 451,9 @@ genDecisionTree' genExpr' genCondBr' genCases' tbody =
            join (foldrM genCase (genDT def selections') cs')

        genDT = \case
            M.DLeaf l -> genDecisionLeaf l
            M.DSwitch selector cs def -> genDecisionSwitchIx selector cs def
            M.DSwitchStr selector cs def -> genDecisionSwitchStr selector cs def
            Ast.DLeaf l -> genDecisionLeaf l
            Ast.DSwitch selector cs def -> genDecisionSwitchIx selector cs def
            Ast.DSwitchStr selector cs def -> genDecisionSwitchStr selector cs def
    in  genDT

genTailCases


@@ 479,7 479,7 @@ genCases tbody selections variantLs variantDts def = do
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi (v : vs)))

selAs :: Span -> [M.Type] -> Operand -> Gen Operand
selAs :: Span -> [Ast.Type] -> Operand -> Gen Operand
selAs totVariants ts matchee = do
    tvariant <- fmap typeStruct (lift (genVariantType totVariants ts))
    let tgeneric = typeOf matchee


@@ 493,7 493,7 @@ selSub span' i matchee =
    let tagOffset = if span' > 1 then 1 else 0
    in  emitReg "submatchee" =<< extractvalue matchee (pure (tagOffset + i))

genCtion :: M.Ction -> Gen Val
genCtion :: Ast.Ction -> Gen Val
genCtion (i, span', dataType, as) = do
    lookupEnum dataType & lift >>= \case
        Just 0 -> pure (VLocal litUnit)

M src/Compile.hs => src/Compile.hs +5 -5
@@ 33,16 33,16 @@ import Prelude hiding (mod)

import Misc
import Conf
import qualified Monomorphic
import qualified Optimized as Ast
import Codegen
import Err
import Pretty


compile :: FilePath -> CompileConfig -> Monomorphic.Program -> IO ()
compile :: FilePath -> CompileConfig -> Ast.Program -> IO ()
compile = handleProgram compileModule

run :: FilePath -> RunConfig -> Monomorphic.Program -> IO ()
run :: FilePath -> RunConfig -> Ast.Program -> IO ()
run = handleProgram orcJitModule

handleProgram


@@ 50,7 50,7 @@ handleProgram
    => (cfg -> TargetMachine -> Module -> IO ())
    -> FilePath
    -> cfg
    -> Monomorphic.Program
    -> Ast.Program
    -> IO ()
handleProgram f file cfg pgm = withContext $ \ctx ->
    -- When `--debug` is given, only -O1 optimize the code. Otherwise, optimize


@@ 86,7 86,7 @@ handleProgram f file cfg pgm = withContext $ \ctx ->
                          when (getDebug cfg) $ writeLLVMAssemblyToFile' ".dbg.opt.ll" mod
                          f cfg tm mod

codegen' :: DataLayout -> FilePath -> Monomorphic.Program -> IO LLAST.Module
codegen' :: DataLayout -> FilePath -> Ast.Program -> IO LLAST.Module
codegen' dl f pgm = case codegen dl f pgm of
    Right m -> pure m
    Left e -> printGenErr e *> abort f

M src/Extern.hs => src/Extern.hs +6 -6
@@ 35,12 35,12 @@ import Data.Functor

import Misc
import SrcPos
import qualified Monomorphic as M
import Monomorphic hiding (Type, Const)
import qualified Optimized as Ast
import Optimized hiding (Type, Const)
import Gen


withExternSigs :: [(String, M.Type, SrcPos)] -> Gen' a -> Gen' a
withExternSigs :: [(String, Ast.Type, SrcPos)] -> Gen' a -> Gen' a
withExternSigs es ga = do
    es' <- forM es $ \(name, t, _) -> do
        t' <- genType' t


@@ 51,17 51,17 @@ withExternSigs es ga = do
            )
    augment globalEnv (Map.fromList es') ga

genExterns :: [(String, M.Type, SrcPos)] -> Gen' [Definition]
genExterns :: [(String, Ast.Type, SrcPos)] -> Gen' [Definition]
genExterns = fmap join . mapM genExtern

genExtern :: (String, M.Type, SrcPos) -> Gen' [Definition]
genExtern :: (String, Ast.Type, SrcPos) -> Gen' [Definition]
genExtern (name, t, pos) = do
    ((pts, rt), (ps, rt')) <- genExternTypeSig t
    let externDef = GlobalDefinition (externFunc (mkName name) ps rt' [] [])
    wrapperDefs <- genWrapper pos name rt pts
    pure (externDef : wrapperDefs)

genWrapper :: SrcPos -> String -> Type -> [M.Type] -> Gen' [Definition]
genWrapper :: SrcPos -> String -> Type -> [Ast.Type] -> Gen' [Definition]
genWrapper pos externName rt = \case
    [] -> ice "genWrapper of empty param list"
    (firstParamT : restParamTs) -> do

M src/Gen.hs => src/Gen.hs +54 -53
@@ 45,16 45,16 @@ import qualified LLSubprog
import Misc
import Pretty
import qualified TypeAst
import qualified Monomorphic as M
import Monomorphic (TypedVar(..), TPrim(..))
import qualified Optimized as Ast
import Optimized (TypedVar(..), TPrim(..))
import qualified Monomorphize
import SrcPos


data GenErr
    = TransmuteErr SrcPos (M.Type, Word64) (M.Type, Word64)
    | CastErr SrcPos M.Type M.Type
    | NoBulitinVirtualInstance SrcPos String M.Type
    = TransmuteErr SrcPos (Ast.Type, Word64) (Ast.Type, Word64)
    | CastErr SrcPos Ast.Type Ast.Type
    | NoBulitinVirtualInstance SrcPos String Ast.Type

type Instr = InstructionMetadata -> Instruction



@@ 159,7 159,8 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
                simpleGlobConst name_inner tInner (LLConst.Array i8 (map litI8' bytes))
            inner = LLConst.GlobalReference (LLType.ptr tInner) name_inner
            ptrBytes = LLConst.BitCast inner typeGenericPtr
            array = litStructNamed ("Array", [M.TPrim (TNat 8)]) [ptrBytes, litI64' len]
            array =
                litStructNamed ("Array", [Ast.TPrim (TNat 8)]) [ptrBytes, litI64' len]
            str = litStructNamed ("Str", []) [array]
            defStr = simpleGlobConst strName typeStr str
        pure (map GlobalDefinition [defInner, defStr])


@@ 231,13 232,13 @@ genFunDef (name, fvs, dpos, ptv@(TypedVar px pt), genBody) = do
        UnName n -> fromString (show n)

genTailWrapInLambdas
    :: Type -> [TypedVar] -> [M.Type] -> ([TypedVar] -> Gen Val) -> Gen Type
    :: Type -> [TypedVar] -> [Ast.Type] -> ([TypedVar] -> Gen Val) -> Gen Type
genTailWrapInLambdas rt fvs ps genBody =
    genWrapInLambdas rt fvs ps genBody >>= getLocal >>= \r -> if typeOf r == typeUnit
        then commitFinalFuncBlock retVoid $> LLType.void
        else commitFinalFuncBlock (ret r) $> typeOf r

genWrapInLambdas :: Type -> [TypedVar] -> [M.Type] -> ([TypedVar] -> Gen Val) -> Gen Val
genWrapInLambdas :: Type -> [TypedVar] -> [Ast.Type] -> ([TypedVar] -> Gen Val) -> Gen Val
genWrapInLambdas rt fvs pts genBody = case pts of
    [] -> genBody fvs
    (pt : pts') -> do


@@ 491,7 492,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
            g
            t
    let arithm u s f = \case
            M.TFun a@(M.TPrim p) (M.TFun b c) | a == b && a == c -> pure
            Ast.TFun a@(Ast.TPrim p) (Ast.TFun b c) | a == b && a == c -> pure
                ( a
                , a
                , genType a


@@ 501,7 502,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
                )
            _ -> noInst
    let bitwise u s = \case
            M.TFun a@(M.TPrim p) (M.TFun b c)
            Ast.TFun a@(Ast.TPrim p) (Ast.TFun b c)
                | a == b && a == c && (isInt' p || isNat p) -> pure
                    ( a
                    , a


@@ 512,7 513,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
                    )
            _ -> noInst
    let rel u s f = \case
            M.TFun a@(M.TPrim p) (M.TFun b _) | a == b -> pure
            Ast.TFun a@(Ast.TPrim p) (Ast.TFun b _) | a == b -> pure
                ( a
                , a
                , pure typeBool


@@ 549,24 550,24 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
        "<" -> wrap2 =<< rel LLIPred.ULT LLIPred.SLT LLFPred.OLT t
        "<=" -> wrap2 =<< rel LLIPred.ULE LLIPred.SLE LLFPred.OLE t
        "transmute" -> wrap1 =<< case t of
            M.TFun a b -> case pos of
            Ast.TFun a b -> case pos of
                Just p -> pure (a, genType b, \x -> genTransmute p x a b)
                Nothing -> ice "genAppBuiltinVirtual: transmute: srcPos is Nothing"
            _ -> noInst
        "cast" -> wrap1 =<< case t of
            M.TFun a b -> case pos of
            Ast.TFun a b -> case pos of
                Just p -> pure (a, genType b, \x -> genCast p x a b)
                Nothing -> ice "genAppBuiltinVirtual: cast: srcPos is Nothing"
            _ -> noInst
        "deref" -> wrap1 =<< case t of
            M.TFun a b -> pure (a, genType b, genDeref)
            Ast.TFun a b -> pure (a, genType b, genDeref)
            _ -> noInst
        "store" -> wrap2 =<< case t of
            M.TFun a (M.TFun b c) -> pure (a, b, genType c, genStore)
            Ast.TFun a (Ast.TFun b c) -> pure (a, b, genType c, genStore)
            _ -> noInst
        _ -> ice $ "genAppBuiltinVirtual: No builtin virtual function `" ++ g ++ "`"
  where
    genTransmute :: SrcPos -> Val -> M.Type -> M.Type -> Gen Val
    genTransmute :: SrcPos -> Val -> Ast.Type -> Ast.Type -> Gen Val
    genTransmute pos x a b = do
        a' <- genType a
        b' <- genType b


@@ 575,7 576,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
        if sa == sb
            then transmute a' b' x
            else throwError (TransmuteErr pos (a, sa) (b, sb))
    genCast :: SrcPos -> Val -> M.Type -> M.Type -> Gen Val
    genCast :: SrcPos -> Val -> Ast.Type -> Ast.Type -> Gen Val
    genCast pos x a b = do
        a' <- genType a
        b' <- genType b


@@ 612,7 613,7 @@ genAppBuiltinVirtual (TypedVar g t) aes = do
        TNatSize -> True
        _ -> False
    isInt = \case
        M.TPrim p -> isInt' p
        Ast.TPrim p -> isInt' p
        _ -> False
    isInt' = \case
        TInt _ -> True


@@ 754,7 755,7 @@ builtinsHidden = Map.fromList
    , ("install_stackoverflow_handler", ([], LLType.void))
    ]

genExternTypeSig :: M.Type -> Gen' (([M.Type], Type), ([Parameter], Type))
genExternTypeSig :: Ast.Type -> Gen' (([Ast.Type], Type), ([Parameter], Type))
genExternTypeSig t = do
    let (pts, rt) = uncurryType t
    when (null pts) $ ice "genExternTypeSig of non-function"


@@ 770,9 771,9 @@ genExternTypeSig t = do
    pure ((pts, rt'), (ps', rt''))
  where

    uncurryType :: M.Type -> ([M.Type], M.Type)
    uncurryType :: Ast.Type -> ([Ast.Type], Ast.Type)
    uncurryType = \case
        M.TFun a b -> first (a :) (uncurryType b)
        Ast.TFun a b -> first (a :) (uncurryType b)
        x -> ([], x)

passByRef :: Type -> Gen Bool


@@ 812,35 813,35 @@ passByRef' = \case
    LabelType -> ice "passByRef of LabelType"
    TokenType -> ice "passByRef of TokenTyp"

genRetType :: M.Type -> Gen Type
genRetType :: Ast.Type -> Gen Type
genRetType = lift . genRetType'

genRetType' :: MonadReader Env m => M.Type -> m Type
genRetType' :: MonadReader Env m => Ast.Type -> m Type
genRetType' = fmap (\t -> if t == typeUnit then LLType.void else t) . genType'

genType :: M.Type -> Gen Type
genType :: Ast.Type -> Gen Type
genType = lift . genType'

-- | Convert to the LLVM representation of a type in an expression-context.
genType' :: MonadReader Env m => M.Type -> m Type
genType' :: MonadReader Env m => Ast.Type -> m Type
genType' = \case
    M.TPrim tc -> pure $ case tc of
        M.TNat w -> IntegerType w
        M.TNatSize -> i64
        M.TInt w -> IntegerType w
        M.TIntSize -> i64
        M.TF16 -> half
        M.TF32 -> float
        M.TF64 -> double
        M.TF128 -> fp128
    M.TFun a r -> liftA2 closureType (genType' a) (genRetType' r)
    M.TBox t -> fmap LLType.ptr (genType' t)
    M.TConst tc -> lookupEnum tc <&> \case
    Ast.TPrim tc -> pure $ case tc of
        Ast.TNat w -> IntegerType w
        Ast.TNatSize -> i64
        Ast.TInt w -> IntegerType w
        Ast.TIntSize -> i64
        Ast.TF16 -> half
        Ast.TF32 -> float
        Ast.TF64 -> double
        Ast.TF128 -> fp128
    Ast.TFun a r -> liftA2 closureType (genType' a) (genRetType' r)
    Ast.TBox t -> fmap LLType.ptr (genType' t)
    Ast.TConst tc -> lookupEnum tc <&> \case
        Just 0 -> typeUnit
        Just w -> IntegerType w
        Nothing -> genDatatypeRef tc

genDatatypeRef :: M.TConst -> Type
genDatatypeRef :: Ast.TConst -> Type
genDatatypeRef = NamedTypeReference . mkName . mangleTConst

-- | A `Fun` is a closure, and follows a certain calling convention


@@ 857,14 858,14 @@ closureFunType :: Type -> Type -> Type
closureFunType a r =
    FunctionType { resultType = r, argumentTypes = [typeGenericPtr, a], isVarArg = False }

genCapturesType :: [M.TypedVar] -> Gen Type
genCapturesType = fmap typeStruct . mapM (\(M.TypedVar _ t) -> genType t)
genCapturesType :: [Ast.TypedVar] -> Gen Type
genCapturesType = fmap typeStruct . mapM (\(Ast.TypedVar _ t) -> genType t)

genVariantType :: MonadReader Env m => M.Span -> [M.Type] -> m [Type]
genVariantType :: MonadReader Env m => Ast.Span -> [Ast.Type] -> m [Type]
genVariantType totVariants =
    fmap (maybe id ((:) . IntegerType) (tagBitWidth totVariants)) . mapM genType'

tagBitWidth :: M.Span -> Maybe Word32
tagBitWidth :: Ast.Span -> Maybe Word32
tagBitWidth span' | span' <= 2 ^ (0 :: Integer) = Nothing
                  | span' <= 2 ^ (8 :: Integer) = Just 8
                  | span' <= 2 ^ (16 :: Integer) = Just 16


@@ 987,10 988,10 @@ newMetadataId = lift newMetadataId'
newMetadataId' :: Gen' MetadataNodeID
newMetadataId' = fmap MetadataNodeID (metadataCount <<+= 1)

lookupEnum :: MonadReader Env m => M.TConst -> m (Maybe Word32)
lookupEnum :: MonadReader Env m => Ast.TConst -> m (Maybe Word32)
lookupEnum tc = view (enumTypes . to (tconstLookup tc))

tconstLookup :: M.TConst -> Map Name a -> Maybe a
tconstLookup :: Ast.TConst -> Map Name a -> Maybe a
tconstLookup = Map.lookup . mkName . mangleTConst

lookupDatatype :: MonadReader Env m => Name -> m Type


@@ 1189,7 1190,7 @@ litStruct = LLConst.Struct Nothing False
--       type. Specifically, I have observed this behaviour i phi-nodes. To
--       guard against it (until fixed upstream, hopefully), store the value in
--       a variable beforehand.
litStructNamed :: M.TConst -> [LLConst.Constant] -> LLConst.Constant
litStructNamed :: Ast.TConst -> [LLConst.Constant] -> LLConst.Constant
litStructNamed t xs =
    let tname = mkName (mangleTConst t) in LLConst.Struct (Just tname) False xs



@@ 1226,7 1227,7 @@ getIntBitWidth = \case
    LLType.IntegerType w -> w
    t -> ice $ "Tried to get bit width of non-integer type " ++ show t

mangleName :: (String, [M.Type]) -> String
mangleName :: (String, [Ast.Type]) -> String
mangleName = \case
    -- Instead of dealing with changing entrypoint name and startfiles, just
    -- call the outermost, compiler generated main `main`, and the user-defined


@@ 1235,16 1236,16 @@ mangleName = \case
    ("main", _) -> ice "mangleName of `main` of non-empty instantiation"
    (x, us) -> x ++ mangleInst us

mangleInst :: [M.Type] -> String
mangleInst :: [Ast.Type] -> String
mangleInst ts =
    if not (null ts) then "<" ++ intercalate ", " (map mangleType ts) ++ ">" else ""

mangleType :: M.Type -> String
mangleType :: Ast.Type -> String
mangleType = \case
    M.TPrim c -> pretty c
    M.TFun p r -> mangleTConst ("Fun", [p, r])
    M.TBox t -> mangleTConst (TypeAst.tBox' t)
    M.TConst tc -> mangleTConst tc
    Ast.TPrim c -> pretty c
    Ast.TFun p r -> mangleTConst ("Fun", [p, r])
    Ast.TBox t -> mangleTConst (TypeAst.tBox' t)
    Ast.TConst tc -> mangleTConst tc

mangleTConst :: M.TConst -> String
mangleTConst :: Ast.TConst -> String
mangleTConst (c, ts) = c ++ mangleInst ts

A src/Optimize.hs => src/Optimize.hs +7 -0
@@ 0,0 1,7 @@
module Optimize (optimize) where

import qualified Monomorphic
import Optimized

optimize :: Monomorphic.Program -> Program
optimize = id

A src/Optimized.hs => src/Optimized.hs +3 -0
@@ 0,0 1,3 @@
module Optimized (module Monomorphic) where

import Monomorphic

M src/Pretty.hs => src/Pretty.hs +9 -9
@@ 15,7 15,7 @@ import Misc
import SrcPos
import qualified Parsed
import qualified Inferred
import qualified Monomorphic as M
import qualified Optimized as Ast


-- Pretty print starting at some indentation depth


@@ 245,21 245,21 @@ prettyAnTFun a b =
    in  concat ["(Fun ", pretty a, " ", spcPretty (bParams ++ [bBody]), ")"]


instance Pretty M.Type where
instance Pretty Ast.Type where
    pretty' _ = prettyMonoType

prettyMonoType :: M.Type -> String
prettyMonoType :: Ast.Type -> String
prettyMonoType = \case
    M.TPrim c -> pretty c
    M.TFun a b -> prettyMonoTFun a b
    M.TBox t -> prettyTBox t
    M.TConst tc -> prettyTConst tc
    Ast.TPrim c -> pretty c
    Ast.TFun a b -> prettyMonoTFun a b
    Ast.TBox t -> prettyTBox t
    Ast.TConst tc -> prettyTConst tc

prettyMonoTFun :: M.Type -> M.Type -> String
prettyMonoTFun :: Ast.Type -> Ast.Type -> String
prettyMonoTFun a b =
    let (bParams, bBody) = f b
        f = \case
            M.TFun a' b' -> first (a' :) (f b')
            Ast.TFun a' b' -> first (a' :) (f b')
            t -> ([], t)
    in  concat ["(Fun ", pretty a, " ", spcPretty (bParams ++ [bBody]), ")"]


M src/Selections.hs => src/Selections.hs +1 -1
@@ 8,7 8,7 @@ import Data.Word
import Control.Monad

import Misc
import Monomorphic
import Optimized


type Selections a = Map Access a

M test/SystemSpec.hs => test/SystemSpec.hs +4 -3
@@ 16,7 16,8 @@ import Parse
import Check
import Compile
import Monomorphize
import qualified Monomorphic
import Optimize
import qualified Optimized as Ast
import Conf

spec :: Spec


@@ 66,7 67,7 @@ compile' f =
            Nothing -> pure False
            Just ast -> compile f cfg ast $> True

frontend :: FilePath -> IO (Maybe Monomorphic.Program)
frontend :: FilePath -> IO (Maybe Ast.Program)
frontend f = parse f <&> \case
    Left _ -> Nothing
    Right ast -> fmap monomorphize (rightToMaybe (typecheck ast))
    Right ast -> fmap (optimize . monomorphize) (rightToMaybe (typecheck ast))