~jojo/Carth

aad7ebb5060ab38ed87b924cd5653e8683e5558d — JoJo 1 year, 7 months ago e3ae404
Preserve topolog. order from Infer to Codegen. Important in genLet

Unlike for global definitions, the bindings of a `let` may be
non-function variables. In the generated code, these variabled must be
defined in topological order, as they'll just be reading undefined
stuff otherwise.
M src/Check.hs => src/Check.hs +7 -7
@@ 35,13 35,13 @@ typecheck (Parsed.Program defs tdefs externs) = runExcept $ do
    let substd = substTopDefs substs inferred
    checkTypeVarsBound substd
    let mTypeDefs = fmap (map (unpos . fst) . snd) tdefs'
    desugared <- compileDecisionTrees mTypeDefs substd
    checkStartDefined desugared
    compiled <- compileDecisionTrees mTypeDefs substd
    checkStartDefined compiled
    let tdefs'' = fmap (second (map snd)) tdefs'
    pure (Checked.Program desugared tdefs'' externs')
    pure (Checked.Program compiled tdefs'' externs')
  where
    checkStartDefined ds =
        when (not (Map.member "start" ds)) (throwError StartNotDefined)
    checkStartDefined (Topo ds) =
        when (not (elem "start" (map fst ds))) (throwError StartNotDefined)

type CheckTypeDefs a
    = ReaderT


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


@@ 199,7 199,7 @@ compileDecisionTrees
    :: MTypeDefs -> Inferred.Defs -> Except TypeErr Checked.Defs
compileDecisionTrees tdefs = compDefs
  where
    compDefs = mapM compDef
    compDefs (Topo defs) = fmap Topo $ mapM (secondM compDef) defs
    compDef (WithPos p rhs) = fmap (WithPos p) (secondM compExpr rhs)
    compExpr :: Inferred.Expr -> Except TypeErr Checked.Expr
    compExpr (WithPos pos ex) = fmap (withPos pos) $ case ex of

M src/Checked.hs => src/Checked.hs +2 -1
@@ 27,6 27,7 @@ where
import Data.Map.Strict (Map)
import Data.Word

import Misc
import SrcPos
import Inferred
    ( TVar(..)


@@ 82,7 83,7 @@ withPos = Expr . Just
noPos :: Expr' -> Expr
noPos = Checked.Expr Nothing

type Defs = Map String (WithPos (Scheme, Expr))
type Defs = TopologicalOrder (String, (WithPos (Scheme, Expr)))
type TypeDefs = Map String ([TVar], [[Type]])
type Externs = Map String Type


M src/Codegen.hs => src/Codegen.hs +5 -6
@@ 62,9 62,8 @@ instance Typed Val where


codegen :: DataLayout -> FilePath -> Program -> Module
codegen layout moduleFilePath (Program defs tdefs externs) =
codegen layout moduleFilePath (Program (Topo defs) tdefs externs) =
    let
        defs' = Map.toList defs
        initEnv =
            Env { _env = Map.empty, _dataTypes = Map.empty, _srcPos = Nothing }
        initSt = St


@@ 83,10 82,10 @@ codegen layout moduleFilePath (Program defs tdefs externs) =
            tdefs'' <- defineDataTypes tdefs
            withDataTypes tdefs''
                $ 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)
    in Module
        { moduleName = fromString ((takeBaseName moduleFilePath))


@@ 500,8 499,8 @@ genCondBr predV genConseq genAlt = do
    fmap VLocal (emitAnonReg (phi [(conseqV, fromConseqL), (altV, fromAltL)]))

genLet :: Defs -> Expr -> Gen Val
genLet ds b = do
    let (vs, es) = unzip (Map.toList ds)
genLet (Topo ds) b = do
    let (vs, es) = unzip ds
    ps <- forM vs $ \(TypedVar n t) -> do
        t' <- genType t
        emitReg n (alloca t')

M src/Infer.hs => src/Infer.hs +10 -8
@@ 141,7 141,7 @@ orderDefs = stronglyConnComp . graph

inferDefsComponents :: [SCC Parsed.Def] -> Infer Defs
inferDefsComponents = \case
    [] -> pure Map.empty
    [] -> pure (Topo [])
    (scc : sccs) -> do
        let (verts, isCyclic) = case scc of
                AcyclicSCC vert -> ([vert], False)


@@ 167,11 167,13 @@ inferDefsComponents = \case
                pure body'
        generalizeds <- mapM generalize ts
        let scms' = zipWith fromMaybe generalizeds mayscms'
        let annotDefs = Map.fromList $ zip
        let annotDefs = zip
                names
                (map (\(p, x, y) -> WithPos p (x, y)) (zip3 poss scms' bodies'))
        annotRest <- withLocals (zip names scms') (inferDefsComponents sccs)
        pure (Map.union annotRest annotDefs)
        Topo annotRest <- withLocals
            (zip names scms')
            (inferDefsComponents sccs)
        pure (Topo (annotDefs ++ annotRest))

-- | Verify that user-provided type signature schemes are valid
checkScheme :: (String, Maybe Parsed.Scheme) -> Infer (Maybe Scheme)


@@ 211,10 213,10 @@ infer (WithPos pos e) = fmap (second (WithPos pos)) $ case e of
        pure (tc, If p' c' a')
    Parsed.Fun p b -> inferFunMatch (pure (p, b))
    Parsed.Let defs b -> do
        annotDefs <- inferDefs defs
        let defsScms = fmap (\(WithPos _ (scm, _)) -> scm) annotDefs
        (bt, b') <- withLocals' defsScms (infer b)
        pure (bt, Let annotDefs b')
        Topo annotDefs <- inferDefs defs
        let defsScms = map (second (\(WithPos _ (scm, _)) -> scm)) annotDefs
        (bt, b') <- withLocals defsScms (infer b)
        pure (bt, Let (Topo annotDefs) b')
    Parsed.TypeAscr x t -> do
        (tx, WithPos _ x') <- infer x
        t' <- checkType pos t

M src/Inferred.hs => src/Inferred.hs +2 -1
@@ 34,6 34,7 @@ import Data.Set (Set)
import Data.Map.Strict (Map)
import Lens.Micro.Platform (makeLenses)

import Misc
import Parsed (TVar(..), TPrim(..), Const(..))
import SrcPos



@@ 97,7 98,7 @@ data Expr'

type Expr = WithPos Expr'

type Defs = Map String (WithPos (Scheme, Expr))
type Defs = TopologicalOrder (String, (WithPos (Scheme, Expr)))
type TypeDefs = Map String ([TVar], [(Id, [Type])])
type Ctors = Map String (VariantIx, (String, [TVar]), [Type], Span)
type Externs = Map String Type

M src/Misc.hs => src/Misc.hs +4 -0
@@ 16,6 16,7 @@ module Misc
    , splitOn
    , (.*)
    , (.**)
    , TopologicalOrder(..)
    )
where



@@ 34,6 35,9 @@ import Text.Megaparsec hiding (parse, match)
import Text.Megaparsec.Char hiding (space, space1)
import Data.Void

newtype TopologicalOrder a = Topo [a]
    deriving Show

ice :: String -> a
ice = error . ("Internal Compiler Error: " ++)


M src/Monomorphic.hs => src/Monomorphic.hs +4 -2
@@ 31,6 31,7 @@ import qualified Data.Set as Set
import Data.Set (Set)
import Data.Word

import Misc
import SrcPos
import Checked (VariantIx, Span)
import FreeVars


@@ 84,7 85,7 @@ data Expr'
data Expr = Expr (Maybe SrcPos) Expr'
    deriving (Show)

type Defs = Map TypedVar (WithPos ([Type], Expr))
type Defs = TopologicalOrder (TypedVar, (WithPos ([Type], Expr)))
type TypeDefs = [(TConst, [VariantTypes])]
type Externs = [(String, Type)]



@@ 103,7 104,8 @@ fvExpr (Expr _ ex) = case ex of
    App f a _ -> fvApp f a
    If p c a -> fvIf p c a
    Fun p (b, _) -> fvFun p b
    Let bs e -> fvLet (Map.keysSet bs, map (snd . unpos) (Map.elems bs)) e
    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)
    Box e -> fvExpr e

M src/Monomorphize.hs => src/Monomorphize.hs +10 -9
@@ 10,6 10,7 @@ import Lens.Micro.Platform (makeLenses, view, use, modifying, to)
import Control.Monad.Reader
import Control.Monad.State
import Data.Functor
import Data.Bifunctor
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe


@@ 84,20 85,20 @@ monoFun (p, tp) (b, bt) = do
    pure (Fun (TypedVar p tp') (b', bt'))

monoLet :: Checked.Defs -> Checked.Expr -> Mono (Defs, Expr)
monoLet ds body = do
    let ks = Map.keys ds
monoLet (Topo ds) body = do
    let ks = map fst ds
    parentInsts <- use (defInsts . to (lookups ks))
    let newEmptyInsts = (fmap (const Map.empty) ds)
    let newEmptyInsts = Map.fromList (zip (map fst ds) (repeat Map.empty))
    modifying defInsts (Map.union newEmptyInsts)
    body' <- augment envDefs (fmap unpos ds) (mono body)
    dsInsts <- use (defInsts . to (lookups ks))
    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' = Map.fromList $ do
            (name, dInsts) <- dsInsts
            let pos = getPos (ds Map.! name)
    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 (ds', body')
    pure (Topo ds', body')

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

M src/Subst.hs => src/Subst.hs +4 -2
@@ 7,6 7,7 @@ import Data.Map.Strict (Map)
import Data.Bifunctor
import Data.Maybe

import Misc
import SrcPos
import Inferred



@@ 15,7 16,7 @@ import Inferred
type Subst = Map TVar Type

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

substDef :: Subst -> WithPos (Scheme, Expr) -> WithPos (Scheme, Expr)
substDef s = mapPos (second (substExpr s))


@@ 26,7 27,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 defs body -> Let (fmap (substDef s) defs) (substExpr s body)
    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)
    Ctor i span' (tx, tts) ps ->
        Ctor i span' (tx, map (subst s) tts) (map (subst s) ps)