~jojo/Carth

360e10362d75a593428d9d266e9a176fa6a10830 — JoJo 1 year, 6 months ago b4845f5
Refactor global & let definitions

Instead of jumbling together function and var defs and just checking
which is which at the end in Codegen, treat them very separately and
remember the grouping for recursive defs.

For now, just moves around complexity really. I don't remember how
exactly, but I thought this would be necessary for the next feature,
which is allowing patterns in left hand side of var defs.
M src/Check.hs => src/Check.hs +38 -21
@@ 42,8 42,9 @@ typecheck (Parsed.Program defs tdefs externs) = runExcept $ do
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Checked.Program compiled tdefs'' externs')
  where
    checkMainDefined (Topo ds) =
        when (not (elem "main" (map fst ds))) (throwError MainNotDefined)
    checkMainDefined ds = when
        (not (elem "main" (map fst (Checked.flattenDefs ds))))
        (throwError MainNotDefined)

type CheckTypeDefs a
    = ReaderT


@@ 169,7 170,7 @@ checkTypeVarsBound :: Inferred.Defs -> Except TypeErr ()
checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
  where
    boundInDefs :: Inferred.Defs -> Bound
    boundInDefs (Topo defs) = mapM_ (secondM boundInDef) defs
    boundInDefs = mapM_ (secondM boundInDef) . Inferred.flattenDefs
    boundInDef (WithPos _ ((Inferred.Forall tvs _), e)) =
        local (Set.union tvs) (boundInExpr e)
    boundInExpr (WithPos pos e) = case e of


@@ 183,10 184,10 @@ checkTypeVarsBound ds = runReaderT (boundInDefs ds) Set.empty
            boundInExpr p
            boundInExpr c
            boundInExpr a
        Inferred.Let lds b -> do
            boundInDefs lds
        Inferred.Let ld b -> do
            mapM_ (secondM boundInDef) (Inferred.defToVarDefs ld)
            boundInExpr b
        Inferred.FunMatch cs pt bt -> do
        Inferred.FunMatch (cs, pt, bt) -> do
            boundInCases cs
            boundInType pos pt
            boundInType pos bt


@@ 219,8 220,31 @@ compileDecisionTrees
    :: MTypeDefs -> Inferred.Defs -> Except TypeErr Checked.Defs
compileDecisionTrees tdefs = compDefs
  where
    compDefs (Topo defs) = fmap Topo $ mapM (secondM compDef) defs
    compDef (WithPos p rhs) = fmap (WithPos p) (secondM compExpr rhs)
    compDefs (Topo defs) = fmap Topo $ mapM compDef defs

    compDef :: Inferred.Def -> Except TypeErr Checked.Def
    compDef = \case
        Inferred.VarDef (lhs, WithPos p rhs) -> fmap
            (Checked.VarDef . (lhs, ) . WithPos p)
            (secondM compExpr rhs)
        Inferred.RecDefs ds ->
            fmap Checked.RecDefs $ flip mapM ds $ secondM $ mapPosdM
                (secondM compFunMatch)

    compFunMatch
        :: WithPos Inferred.FunMatch -> Except TypeErr (WithPos Checked.Fun)
    compFunMatch (WithPos pos (cs, tp, tb)) = do
        cs' <- mapM (secondM compExpr) cs
        let p = "#x"
        fmap (WithPos pos)
            $ case runExceptT (toDecisionTree tdefs pos tp cs') of
                Nothing -> pure ((p, tp), (noPos (Checked.Absurd tb), tb))
                Just e -> do
                    dt <- liftEither e
                    let v = noPos (Checked.Var (Checked.TypedVar p tp))
                        b = noPos (Checked.Match v dt tb)
                    pure ((p, tp), (b, tb))

    compExpr :: Inferred.Expr -> Except TypeErr Checked.Expr
    compExpr (WithPos pos ex) = fmap (withPos pos) $ case ex of
        Inferred.Lit c -> pure (Checked.Lit c)


@@ 230,18 254,9 @@ compileDecisionTrees tdefs = compDefs
            liftA3 Checked.App (compExpr f) (compExpr a) (pure tr)
        Inferred.If p c a ->
            liftA3 Checked.If (compExpr p) (compExpr c) (compExpr a)
        Inferred.Let lds b ->
            liftA2 Checked.Let (compDefs lds) (compExpr b)
        Inferred.FunMatch cs tp tb -> do
            cs' <- mapM (secondM compExpr) cs
            case runExceptT (toDecisionTree tdefs pos tp cs') of
                Nothing -> pure (Checked.Absurd tb)
                Just e -> do
                    dt <- liftEither e
                    let p = "#x"
                        v = noPos (Checked.Var (Checked.TypedVar p tp))
                        b = noPos (Checked.Match v dt tb)
                    pure (Checked.Fun (p, tp) (b, tb))
        Inferred.Let ld b -> liftA2 Checked.Let (compDef ld) (compExpr b)
        Inferred.FunMatch fm ->
            fmap (Checked.Fun . unpos) (compFunMatch (WithPos pos fm))
        Inferred.Ctor v span' inst ts ->
            let
                xs = map


@@ 253,7 268,9 @@ compileDecisionTrees tdefs = compDefs
                    params
            in pure $ snd $ foldr
                (\(p, pt) (bt, b) ->
                    (Inferred.TFun pt bt, Checked.Fun (p, pt) (noPos b, bt))
                    ( Inferred.TFun pt bt
                    , Checked.Fun ((p, pt), (noPos b, bt))
                    )
                )
                (Inferred.TConst inst, Checked.Ction v span' inst args)
                params

M src/Checked.hs => src/Checked.hs +24 -3
@@ 1,3 1,5 @@
{-# LANGUAGE LambdaCase #-}

module Checked
    ( module Checked
    , TVar(..)


@@ 14,6 16,7 @@ where

import Data.Map.Strict (Map)
import Data.Word
import Data.Bifunctor

import Misc
import SrcPos


@@ 49,13 52,15 @@ data DecisionTree
    | DSwitchStr Access (Map String DecisionTree) DecisionTree
    deriving Show

type Fun = ((String, Type), (Expr, Type))

data Expr'
    = Lit Const
    | Var TypedVar
    | App Expr Expr Type
    | If Expr Expr Expr
    | Fun (String, Type) (Expr, Type)
    | Let Defs Expr
    | Fun Fun
    | Let Def Expr
    | Match Expr DecisionTree Type
    | Ction VariantIx Span TConst [Expr]
    | Sizeof Type


@@ 78,9 83,25 @@ withPos = Expr . Just
noPos :: Expr' -> Expr
noPos = Checked.Expr Nothing

type Defs = TopologicalOrder (String, (WithPos (Scheme, Expr)))
type Defs = TopologicalOrder Def
data Def = VarDef VarDef | RecDefs RecDefs deriving Show
type VarDef = (String, WithPos (Scheme, Expr))
type RecDefs = [(String, WithPos (Scheme, WithPos Fun))]
type TypeDefs = Map String ([TVar], [[Type]])
type Externs = Map String (Type, SrcPos)

data Program = Program Defs TypeDefs Externs
    deriving (Show)


flattenDefs :: Defs -> [(String, WithPos (Scheme, Expr))]
flattenDefs (Topo defs) = defToVarDefs =<< defs

defToVarDefs :: Def -> [(String, WithPos (Scheme, Expr))]
defToVarDefs = \case
    VarDef d -> [d]
    RecDefs ds -> map funDefToVarDef ds

funDefToVarDef :: (String, WithPos (Scheme, WithPos Fun)) -> VarDef
funDefToVarDef =
    second (mapPosd (second (\(WithPos p f) -> Expr (Just p) (Fun f))))

M src/Codegen.hs => src/Codegen.hs +42 -47
@@ 47,16 47,17 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
            let
                (enums, tdefs'') =
                    runIdentity (runGen' (defineDataTypes tdefs))
                defs' = defToVarDefs =<< defs
            in
                runGen'
                $ augment enumTypes enums
                $ augment dataTypes tdefs''
                $ withBuiltins
                $ withExternSigs externs
                $ withGlobDefSigs (map (second unpos) defs)
                $ withGlobDefSigs (map (second unpos) defs')
                $ do
                    es <- genExterns externs
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs))
                    ds <- liftA2 (:) genMain (fmap join (mapM genGlobDef defs'))
                    pure (tdefs'', es, ds)
        pure $ Module
            { moduleName = fromString ((takeBaseName moduleFilePath))


@@ 84,6 85,7 @@ codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
                    (mkName (mangleName (x, us)))
                )
        augment env (Map.fromList sigs') ga

    fileId = MetadataNodeID 1
    debugInfoVersionId = MetadataNodeID 2
    globMetadataDefs =


@@ 181,9 183,9 @@ genMain = do
--       start, or an interpretation step is added between monomorphization and
--       codegen that evaluates all expressions in relevant contexts, like
--       constexprs.
genGlobDef :: (TypedVar, WithPos ([M.Type], Expr)) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, (Expr _ e))) = case e of
    Fun p (body, rt) -> do
genGlobDef :: (TypedVar, WithPos ([M.Type], Expr')) -> Gen' [Definition]
genGlobDef (TypedVar v _, WithPos dpos (ts, e)) = case e of
    Fun (p, (body, rt)) -> do
        let var = (v, ts)
        let name = mangleName var
        assign lambdaParentFunc (Just name)


@@ 205,10 207,10 @@ genTailExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
    case expr of
        App f e _ -> genTailApp f e
        If p c a -> genTailIf p c a
        Let ds b -> genTailLet ds b
        Let d b -> genTailLet d b
        Match e cs tbody -> genTailMatch e cs =<< genType tbody
        _ -> genTailReturn =<< case expr of
            Fun p b -> assign lambdaParentFunc parent *> genExprLambda p b
            Fun (p, b) -> assign lambdaParentFunc parent *> genExprLambda p b
            _ -> genExpr (Expr pos expr)

genTailReturn :: Val -> Gen ()


@@ 224,8 226,8 @@ genExpr (Expr pos expr) = locally srcPos (pos <|>) $ do
        Var (TypedVar x t) -> lookupVar (TypedVar x t)
        App f e _ -> genApp f e
        If p c a -> genIf p c a
        Fun p b -> assign lambdaParentFunc parent *> genExprLambda p b
        Let ds b -> genLet ds b
        Fun (p, b) -> assign lambdaParentFunc parent *> genExprLambda p b
        Let d b -> genLet d b
        Match e cs tbody -> genMatch e cs =<< genType tbody
        Ction c -> genCtion c
        Sizeof t ->


@@ 269,7 271,7 @@ genBetaReduceApp
    -> (Expr, [Expr])
    -> Gen a
genBetaReduceApp genExpr' returnMethod app' = \case
    (Expr _ (Fun p (b, _)), ae : aes) -> do
    (Expr _ (Fun (p, (b, _))), ae : aes) -> do
        a <- genExpr ae
        withVal p a (genBetaReduceApp genExpr' returnMethod app' (b, aes))
    (Expr _ (App fe ae _), aes) ->


@@ 329,43 331,36 @@ genCondBr predV genConseq genAlt = do
    commitToNewBlock (br nextL) nextL
    fmap VLocal (emitAnonReg (phi [(conseqV, fromConseqL), (altV, fromAltL)]))

genTailLet :: Defs -> Expr -> Gen ()
genTailLet ds = genLet' ds . genTailExpr

genLet :: Defs -> Expr -> Gen Val
genLet ds = genLet' ds . genExpr

genLet' :: Defs -> Gen a -> Gen a
genLet' (Topo ds) genBody = do
    -- For both function and variable bindings, we need separate the definition
    -- into two passes, where the first pre-allocates some stuff.
    (binds, cs) <- fmap unzip $ forM ds $ \case
        (v, WithPos _ (_, Expr _ (Fun p (fb, fbt)))) -> do
            let fvXs = Set.toList (Set.delete p (freeVars fb))
            tcaptures <- fmap
                typeStruct
                (mapM (\(TypedVar _ t) -> genType t) fvXs)
            captures <- genHeapAllocGeneric tcaptures
            fbt' <- genRetType fbt
            l <-
                getVar
                    =<< genLambda'
                            p
                            (genTailExpr fb, fbt')
                            (VLocal captures)
                            fvXs
            pure ((v, l), Left (captures, fvXs))
        (v@(TypedVar n t), WithPos _ (_, e)) -> do
            t' <- genType t
            mem <- emitReg n (alloca t')
            pure ((v, mem), Right e)
    withVars binds $ do
        forM_ (zip binds cs) $ \case
            (_, Left (captures, fvXs)) -> populateCaptures captures fvXs
            ((_, mem), Right e) -> do
                x <- getLocal =<< genExpr e
                emitDo (store x mem)
        genBody
genTailLet :: Def -> Expr -> Gen ()
genTailLet d = genLet' d . genTailExpr

genLet :: Def -> Expr -> Gen Val
genLet d = genLet' d . genExpr

genLet' :: Def -> Gen a -> Gen a
genLet' def genBody = case def of
    VarDef (lhs, WithPos pos (_, rhs)) ->
        genExpr (Expr (Just pos) rhs) >>= \rhs' -> withVal lhs rhs' genBody
    RecDefs ds -> do
        (binds, cs) <- fmap unzip $ forM ds $ \case
            (lhs, WithPos _ (_, (p, (fb, fbt)))) -> do
                let fvXs = Set.toList (Set.delete p (freeVars fb))
                tcaptures <- fmap
                    typeStruct
                    (mapM (\(TypedVar _ t) -> genType t) fvXs)
                captures <- genHeapAllocGeneric tcaptures
                fbt' <- genRetType fbt
                lam <-
                    getVar
                        =<< genLambda'
                                p
                                (genTailExpr fb, fbt')
                                (VLocal captures)
                                fvXs
                pure ((lhs, lam), (captures, fvXs))
        withVars binds $ do
            forM_ cs (uncurry populateCaptures)
            genBody

genTailMatch :: Expr -> DecisionTree -> Type -> Gen ()
genTailMatch m dt tbody = do

M src/Infer.hs => src/Infer.hs +54 -45
@@ 16,13 16,15 @@ import Data.Map.Strict (Map)
import Data.Maybe
import qualified Data.Set as Set
import Data.Set (Set)
import Control.Arrow ((>>>))

import Misc
import SrcPos
import FreeVars
import Subst
import qualified Parsed
import Parsed (Id(..), IdCase(..), idstr, isFunLike)
import Parsed (Id(..), IdCase(..), idstr)
import Err
import Inferred hiding (Id)




@@ 130,44 132,50 @@ orderDefs = stronglyConnComp . graph
    where graph = map (\d@(n, _) -> (d, n, Set.toList (freeVars d)))

inferDefsComponents :: [SCC Parsed.Def] -> Infer Defs
inferDefsComponents = \case
    [] -> pure (Topo [])
    (scc : sccs) -> do
        let (verts, isCyclic) = case scc of
                AcyclicSCC vert -> ([vert], False)
                CyclicSCC verts' -> (verts', True)
        let (idents, rhss) = unzip verts
        let (poss, mayscms, bodies) =
                unzip3 (map (\(WithPos p (x, y)) -> (p, x, y)) rhss)
        let names = map idstr idents
        mayscms' <- mapM checkScheme (zip names mayscms)
        ts <- replicateM (length names) fresh
        let scms = map
                (\(mayscm, t) -> fromMaybe (Forall Set.empty t) mayscm)
                (zip mayscms' ts)
        forM_ (zip idents bodies) $ \(Id name, body) ->
            when (not (isFunLike body) && isCyclic)
                $ throwError (RecursiveVarDef name)
        bodies' <-
            withLocals (zip names scms)
            $ forM (zip bodies scms)
            $ \(body, Forall _ t1) -> do
                (t2, body') <- infer body
                unify (Expected t1) (Found (getPos body) t2)
                pure body'
        generalizeds <- mapM generalize ts
        let scms' = zipWith fromMaybe generalizeds mayscms'
        let annotDefs = zip
                names
                (map (\(p, x, y) -> WithPos p (x, y)) (zip3 poss scms' bodies'))
        Topo annotRest <- withLocals
            (zip names scms')
            (inferDefsComponents sccs)
        pure (Topo (annotDefs ++ annotRest))
inferDefsComponents = flip foldr (pure (Topo [])) $ \scc inferRest -> do
    def <- inferComponent scc
    Topo rest <- withLocals (defSigs def) inferRest
    pure (Topo (def : rest))
  where
    inferComponent :: SCC Parsed.Def -> Infer Def
    inferComponent = \case
        AcyclicSCC vert -> fmap VarDef (inferVarDef vert)
        CyclicSCC verts -> fmap RecDefs (inferRecDefs verts)

    inferVarDef :: Parsed.Def -> Infer VarDef
    inferVarDef (lhs, WithPos defPos (mayscm, body)) = do
        t <- fresh
        body' <- inferDef t lhs mayscm (getPos body) (infer body)
        scm <- generalize t
        pure (idstr lhs, WithPos defPos (scm, body'))

    inferRecDefs :: [Parsed.Def] -> Infer RecDefs
    inferRecDefs ds = do
        ts <- replicateM (length ds) fresh
        let dummyScms = map (Forall Set.empty) ts
        let (names, poss) = unzip (map (bimap idstr getPos) ds)
        fs <- withLocals (zip names dummyScms) $ zipWithM inferRecDef ts ds
        scms <- mapM generalize ts
        pure (zip names (zipWith3 (curry . WithPos) poss scms fs))

    inferRecDef :: Type -> Parsed.Def -> Infer (WithPos FunMatch)
    inferRecDef t = uncurry $ \(Id lhs) -> unpos >>> \case
        (mayscm, WithPos fPos (Parsed.FunMatch cs)) ->
            fmap (WithPos fPos)
                $ inferDef t (Id lhs) mayscm fPos (inferFunMatch cs)
        _ -> throwError (RecursiveVarDef lhs)

    inferDef t lhs mayscm bodyPos inferBody = do
        checkScheme (idstr lhs) mayscm >>= \case
            Just (Forall _ scmt) -> unify (Expected scmt) (Found bodyPos t)
            Nothing -> pure ()
        (t', body') <- inferBody
        unify (Expected t) (Found bodyPos t')
        pure body'

-- | Verify that user-provided type signature schemes are valid
checkScheme :: (String, Maybe Parsed.Scheme) -> Infer (Maybe Scheme)
checkScheme = \case
checkScheme :: String -> Maybe Parsed.Scheme -> Infer (Maybe Scheme)
checkScheme = curry $ \case
    ("main", Nothing) -> pure (Just (Forall Set.empty mainType))
    ("main", Just s@(Parsed.Forall pos vs t))
        | Set.size vs /= 0 || t /= Parsed.mainType -> throwError


@@ 202,10 210,11 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        unify (Expected tc) (Found (getPos a) ta)
        pure (tc, If p' c' a')
    Parsed.Let defs b -> do
        Topo annotDefs <- inferDefs defs
        let defsScms = map (second (\(WithPos _ (scm, _)) -> scm)) annotDefs
        (bt, b') <- withLocals defsScms (infer b)
        pure (bt, Let (Topo annotDefs) b')
        Topo defs' <- inferDefs defs
        let withDef def inferX = do
                (tx, x') <- withLocals (defSigs def) inferX
                pure (tx, WithPos pos (Let def x'))
        fmap (second unpos) (foldr withDef (infer b) defs')
    Parsed.TypeAscr x t -> do
        (tx, WithPos _ x') <- infer x
        t' <- checkType pos t


@@ 214,9 223,9 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Parsed.Match matchee cases -> do
        (tmatchee, matchee') <- infer matchee
        (tbody, cases') <- inferCases (Expected tmatchee) cases
        let f = WithPos pos (FunMatch cases' tmatchee tbody)
        let f = WithPos pos (FunMatch (cases', tmatchee, tbody))
        pure (tbody, App f matchee' tbody)
    Parsed.FunMatch cases -> inferFunMatch cases
    Parsed.FunMatch cases -> fmap (second FunMatch) (inferFunMatch cases)
    Parsed.Ctor c -> inferExprConstructor c
    Parsed.Sizeof t -> fmap ((TPrim TInt, ) . Sizeof) (checkType pos t)
    Parsed.Deref x -> do


@@ 233,11 242,11 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
    Parsed.Transmute x ->
        fresh >>= \u -> infer x <&> \(t, x') -> (u, Transmute x' t u)

inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, Expr')
inferFunMatch :: [(Parsed.Pat, Parsed.Expr)] -> Infer (Type, FunMatch)
inferFunMatch cases = do
    tpat <- fresh
    (tbody, cases') <- inferCases (Expected tpat) cases
    pure (TFun tpat tbody, FunMatch cases' tpat tbody)
    pure (TFun tpat tbody, (cases', tpat, tbody))

-- | All the patterns must be of the same types, and all the bodies must be of
--   the same type.

M src/Inferred.hs => src/Inferred.hs +21 -3
@@ 91,14 91,15 @@ data Pat'
type Pat = WithPos Pat'

type Cases = [(Pat, Expr)]
type FunMatch = (Cases, Type, Type)

data Expr'
    = Lit Const
    | Var TypedVar
    | App Expr Expr Type
    | If Expr Expr Expr
    | Let Defs Expr
    | FunMatch Cases Type Type
    | Let Def Expr
    | FunMatch FunMatch
    | Ctor VariantIx Span TConst [Type]
    | Sizeof Type
    | Deref Expr


@@ 108,7 109,10 @@ data Expr'

type Expr = WithPos Expr'

type Defs = TopologicalOrder (String, (WithPos (Scheme, Expr)))
type Defs = TopologicalOrder Def
data Def = VarDef VarDef | RecDefs RecDefs deriving Show
type VarDef = (String, WithPos (Scheme, Expr))
type RecDefs = [(String, WithPos (Scheme, WithPos FunMatch))]
type TypeDefs = Map String ([TVar], [(Id, [Type])])
type Ctors = Map String (VariantIx, (String, [TVar]), [Type], Span)
type Externs = Map String (Type, SrcPos)


@@ 134,6 138,20 @@ builtinExterns = Map.fromList $ map
    (second (, SrcPos "<builtin>" 0 0))
    [("GC_malloc", TFun (TPrim TInt) (TBox (TConst tUnit)))]

defSigs :: Def -> [(String, Scheme)]
defSigs = \case
    VarDef d -> [defSig d]
    RecDefs ds -> map defSig ds
    where defSig d = (fst d, fst (unpos (snd d)))

flattenDefs :: Defs -> [(String, WithPos (Scheme, Expr))]
flattenDefs (Topo defs) = defToVarDefs =<< defs

defToVarDefs :: Def -> [(String, WithPos (Scheme, Expr))]
defToVarDefs = \case
    VarDef d -> [d]
    RecDefs ds -> map (second (mapPosd (second (mapPosd FunMatch)))) ds

mainType :: Type
mainType = TFun (TConst tUnit) (TConst tUnit)


M src/Misc.hs => src/Misc.hs +4 -0
@@ 52,6 52,10 @@ locallySet l = locally l . const
locally :: MonadReader s m => Lens' s a -> (a -> a) -> m r -> m r
locally l f = local (over l f)

augment1
    :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> (k, v) -> m a -> m a
augment1 l = locally l . uncurry Map.insert

augment
    :: (MonadReader e m, Ord k) => Lens' e (Map k v) -> Map k v -> m a -> m a
augment l = locally l . Map.union

M src/Monomorphic.hs => src/Monomorphic.hs +37 -15
@@ 17,6 17,7 @@ import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Word
import Data.Bifunctor

import Misc
import SrcPos


@@ 54,14 55,15 @@ data DecisionTree
    deriving Show

type Ction = (VariantIx, Span, TConst, [Expr])
type Fun = (TypedVar, (Expr, Type))

data Expr'
    = Lit Const
    | Var TypedVar
    | App Expr Expr Type
    | If Expr Expr Expr
    | Fun TypedVar (Expr, Type)
    | Let Defs Expr
    | Fun Fun
    | Let Def Expr
    | Match Expr DecisionTree Type
    | Ction Ction
    | Sizeof Type


@@ 74,7 76,10 @@ data Expr'
data Expr = Expr (Maybe SrcPos) Expr'
    deriving (Show)

type Defs = TopologicalOrder (TypedVar, (WithPos ([Type], Expr)))
type Defs = TopologicalOrder Def
data Def = VarDef VarDef | RecDefs RecDefs deriving Show
type VarDef = (TypedVar, WithPos ([Type], Expr'))
type RecDefs = [(TypedVar, WithPos ([Type], Fun))]
type TypeDefs = [(TConst, [VariantTypes])]
type Externs = [(String, Type, SrcPos)]



@@ 83,34 88,51 @@ data Program = Program Defs TypeDefs Externs


instance FreeVars Expr TypedVar where
    freeVars = fvExpr
    freeVars (Expr _ e) = fvExpr' e

instance FreeVars Expr' TypedVar where
    freeVars = fvExpr'

fvExpr :: Expr -> Set TypedVar
fvExpr (Expr _ ex) = case ex of

expr' :: Expr -> Expr'
expr' (Expr _ e) = e

fvExpr' :: Expr' -> Set TypedVar
fvExpr' = \case
    Lit _ -> Set.empty
    Var x -> Set.singleton x
    App f a _ -> fvApp f a
    If p c a -> fvIf p c a
    Fun p (b, _) -> fvFun p b
    Let (Topo bs) e ->
        fvLet (Set.fromList (map fst bs), map (snd . unpos) (map snd bs)) e
    Match e dt _ -> Set.union (fvExpr e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map fvExpr as)
    Fun (p, (b, _)) -> fvFun p b
    Let d (Expr _ e) ->
        let bs = defToVarDefs d
        in fvLet (Set.fromList (map fst bs), map (snd . unpos . snd) bs) e
    Match e dt _ -> Set.union (freeVars e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map freeVars as)
    Sizeof _t -> Set.empty
    Deref e -> fvExpr e
    Store x p -> Set.union (fvExpr x) (fvExpr p)
    Deref e -> freeVars e
    Store x p -> Set.union (freeVars x) (freeVars p)
    Absurd _ -> Set.empty
    Transmute _ x _ _ -> fvExpr x
    Transmute _ x _ _ -> freeVars x

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case
    DLeaf (bs, e) -> Set.difference (fvExpr e) (Set.fromList (map fst bs))
    DLeaf (bs, e) -> Set.difference (freeVars e) (Set.fromList (map fst bs))
    DSwitch _ cs def -> fvDSwitch (Map.elems cs) def
    DSwitchStr _ cs def -> fvDSwitch (Map.elems cs) def
  where
    fvDSwitch es def =
        Set.unions $ fvDecisionTree def : map fvDecisionTree es

defToVarDefs :: Def -> [(TypedVar, WithPos ([Type], Expr'))]
defToVarDefs = \case
    VarDef d -> [d]
    RecDefs ds -> map (second (mapPosd (second Fun))) ds

funDefFromVarDef :: VarDef -> (TypedVar, WithPos ([Type], Fun))
funDefFromVarDef = second $ mapPosd $ second $ \case
    Fun f -> f
    e -> ice $ "funDefFromVarDef on non-positioned function " ++ show e

mainType :: Type
mainType = TFun (TConst tUnit) (TConst tUnit)

M src/Monomorphize.hs => src/Monomorphize.hs +42 -25
@@ 31,7 31,7 @@ data Env = Env
makeLenses ''Env

data Insts = Insts
    { _defInsts :: Map String (Map Type ([Type], Expr))
    { _defInsts :: Map String (Map Type ([Type], Expr'))
    , _tdefInsts :: Set TConst
    }
makeLenses ''Insts


@@ 40,15 40,18 @@ makeLenses ''Insts
type Mono = StateT Insts (Reader Env)

monomorphize :: Checked.Program -> Program
monomorphize (Checked.Program defs tdefs externs) = evalMono $ do
monomorphize (Checked.Program (Topo defs) tdefs externs) = evalMono $ do
    externs' <- mapM
        (\(x, (t, p)) -> fmap (\t' -> (x, t', p)) (monotype t))
        (Map.toList externs)
    (defs', _) <- monoLet
    let callMain =
            noPos (Checked.Var (Checked.TypedVar "main" Checked.mainType))
    defs' <- foldr
        (\d1 md2s -> fmap (uncurry (++)) (monoLet' d1 md2s))
        (mono callMain $> [])
        defs
        (noPos (Checked.Var (Checked.TypedVar "main" Checked.mainType)))
    tdefs' <- instTypeDefs tdefs
    pure (Program defs' tdefs' externs')
    pure (Program (Topo defs') tdefs' externs')

builtinExterns :: Map String Type
builtinExterns = evalMono (mapM monotype Checked.builtinExterns)


@@ 74,8 77,8 @@ mono (Checked.Expr pos ex) = fmap (Expr pos) $ case ex of
        pure (Var (TypedVar x t'))
    Checked.App f a rt -> liftA3 App (mono f) (mono a) (monotype rt)
    Checked.If p c a -> liftA3 If (mono p) (mono c) (mono a)
    Checked.Fun p b -> monoFun p b
    Checked.Let ds b -> fmap (uncurry Let) (monoLet ds b)
    Checked.Fun (p, b) -> monoFun p b
    Checked.Let d e -> monoLet pos d e
    Checked.Match e cs tbody -> monoMatch e cs tbody
    Checked.Ction v span' inst as -> monoCtion v span' inst as
    Checked.Sizeof t -> fmap Sizeof (monotype t)


@@ 93,23 96,37 @@ monoFun (p, tp) (b, bt) = do
    b' <- mono b
    bt' <- monotype bt
    maybe (pure ()) (modifying defInsts . Map.insert p) parentInst
    pure (Fun (TypedVar p tp') (b', bt'))

monoLet :: Checked.Defs -> Checked.Expr -> Mono (Defs, Expr)
monoLet (Topo ds) body = do
    let ks = map fst ds
    parentInsts <- use (defInsts . to (lookups ks))
    let newEmptyInsts = Map.fromList (zip (map fst ds) (repeat Map.empty))
    modifying defInsts (Map.union newEmptyInsts)
    body' <- augment envDefs (Map.fromList (map (second unpos) ds)) (mono body)
    dsInsts <- use (defInsts . to (Map.fromList . lookups ks))
    modifying defInsts (Map.union (Map.fromList parentInsts))
    let ds' = do
            (name, WithPos pos _) <- ds
            let dInsts = dsInsts Map.! name
            (t, (us, dbody)) <- Map.toList dInsts
            pure (TypedVar name t, WithPos pos (us, dbody))
    pure (Topo ds', body')
    pure (Fun (TypedVar p tp', (b', bt')))

monoLet :: Maybe SrcPos -> Checked.Def -> Checked.Expr -> Mono Expr'
monoLet pos d e = do
    (ds', e') <- monoLet' d (mono e)
    let Expr _ l = foldr (Expr pos .* Let) e' ds'
    pure l

monoLet' :: Checked.Def -> Mono a -> Mono ([Def], a)
monoLet' def ma = case def of
    Checked.VarDef d -> fmap (first (map VarDef)) (monoLetVar d ma)
    Checked.RecDefs ds -> fmap (first (pure . RecDefs)) (monoLetRecs ds ma)

monoLetVar :: Checked.VarDef -> Mono a -> Mono ([VarDef], a)
monoLetVar (lhs, rhs) monoBody = do
    parentInsts <- use (defInsts . to (Map.lookup lhs))
    modifying defInsts (Map.insert lhs Map.empty)
    body' <- augment1 envDefs (lhs, unpos rhs) monoBody
    dInsts <- use (defInsts . to (Map.! lhs))
    mapM_ (modifying defInsts . Map.insert lhs) parentInsts
    let ds' = Map.toList dInsts <&> \(t, (us, dbody)) ->
            (TypedVar lhs t, WithPos (getPos rhs) (us, dbody))
    pure (ds', body')

monoLetRecs :: Checked.RecDefs -> Mono a -> Mono (RecDefs, a)
monoLetRecs ds ma = foldr
    (\d1 mb -> monoLetVar (Checked.funDefToVarDef d1) mb
        <&> \(d1's, (d2s, b)) -> (map funDefFromVarDef d1's ++ d2s, b)
    )
    (fmap ([], ) ma)
    ds

monoMatch :: Checked.Expr -> Checked.DecisionTree -> Checked.Type -> Mono Expr'
monoMatch e dt tbody =


@@ 169,7 186,7 @@ addDefInst x t1 = do
                let boundTvs = bindTvs t2 t1
                    instTs = Map.elems boundTvs
                insertInst t1 (instTs, body')
                augment tvBinds boundTvs (mono body)
                augment tvBinds boundTvs (fmap expr' (mono body))
            pure ()
    where insertInst t b = modifying defInsts (Map.adjust (Map.insert t b) x)


M src/Parsed.hs => src/Parsed.hs +1 -6
@@ 81,7 81,7 @@ data Expr'

type Expr = WithPos Expr'

type Def = (Id 'Small, (WithPos (Maybe Scheme, Expr)))
type Def = (Id 'Small, WithPos (Maybe Scheme, Expr))

newtype ConstructorDefs = ConstructorDefs [(Id 'Big, [Type])]
    deriving (Show, Eq)


@@ 158,8 158,3 @@ mainType = TFun (TConst tUnit) (TConst tUnit)

tUnit :: (String, [a])
tUnit = ("Unit", [])

isFunLike :: Expr -> Bool
isFunLike (WithPos _ e) = case e of
    FunMatch _ -> True
    _ -> False

M src/SrcPos.hs => src/SrcPos.hs +6 -11
@@ 1,12 1,4 @@
module SrcPos
    ( SrcPos(..)
    , WithPos(..)
    , HasPos(..)
    , mapPos
    , unpos
    , prettySrcPos
    )
where
module SrcPos where

import Text.Megaparsec.Pos



@@ 33,8 25,11 @@ instance Ord a => Ord (WithPos a) where
instance HasPos (WithPos a) where
    getPos (WithPos p _) = p

mapPos :: (a -> b) -> WithPos a -> WithPos b
mapPos f (WithPos p a) = WithPos p (f a)
mapPosd :: (a -> b) -> WithPos a -> WithPos b
mapPosd f (WithPos p a) = WithPos p (f a)

mapPosdM :: Monad m => (a -> m b) -> WithPos a -> m (WithPos b)
mapPosdM f (WithPos p a) = fmap (WithPos p) (f a)

unpos :: WithPos a -> a
unpos (WithPos _ a) = a

M src/Subst.hs => src/Subst.hs +11 -6
@@ 16,10 16,13 @@ import Inferred
type Subst = Map TVar Type

substTopDefs :: Subst -> Defs -> Defs
substTopDefs s (Topo defs) = Topo (map (second (substDef s)) defs)
substTopDefs s (Topo defs) = Topo (map (substDef s) defs)

substDef :: Subst -> WithPos (Scheme, Expr) -> WithPos (Scheme, Expr)
substDef s = mapPos (second (substExpr s))
substDef :: Subst -> Def -> Def
substDef s = \case
    VarDef d -> VarDef (second (mapPosd (second (substExpr s))) d)
    RecDefs ds ->
        RecDefs (map (second (mapPosd (second (mapPosd (substFunMatch s))))) ds)

substExpr :: Subst -> Expr -> Expr
substExpr s (WithPos pos expr) = WithPos pos $ case expr of


@@ 27,9 30,8 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    Var v -> Var (substTypedVar s v)
    App f a rt -> App (substExpr s f) (substExpr s a) (subst s rt)
    If p c a -> If (substExpr s p) (substExpr s c) (substExpr s a)
    Let (Topo defs) body ->
        Let (Topo (map (second (substDef s)) defs)) (substExpr s body)
    FunMatch cs tp tb -> FunMatch (substCases s cs) (subst s tp) (subst s tb)
    Let def body -> Let (substDef s def) (substExpr s body)
    FunMatch f -> FunMatch (substFunMatch s f)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)
    Sizeof t -> Sizeof (subst s t)


@@ 37,6 39,9 @@ substExpr s (WithPos pos expr) = WithPos pos $ case expr of
    Store x p -> Store (substExpr s x) (substExpr s p)
    Transmute e t u -> Transmute (substExpr s e) (subst s t) (subst s u)

substFunMatch :: Subst -> FunMatch -> FunMatch
substFunMatch s (cs, tp, tb) = ((substCases s cs), (subst s tp), (subst s tb))

substCases :: Subst -> Cases -> Cases
substCases s cs = map (bimap (substPat s) (substExpr s)) cs