~jojo/Carth

ref: 749208029494a7c48ce04444a513424f4b998416 Carth/src/Monomorphic.hs -rw-r--r-- 3.3 KiB
74920802JoJo update TODO 6 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
{-# LANGUAGE TemplateHaskell #-}

-- | Monomorphic AST as a result of monomorphization
module Monomorphic (module Monomorphic, TPrim(..), Const(..), VariantIx, Span, tUnit) where

import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Word
import Data.Bifunctor

import Misc
import SrcPos
import Checked (VariantIx, Span)
import FreeVars
import Parsed (Const(..))
import TypeAst hiding (TConst)
import qualified TypeAst

type TConst = TypeAst.TConst Type

data Type
    = TPrim TPrim
    | TFun Type Type
    | TBox Type
    | TConst TConst
    deriving (Show, Eq, Ord)

data TypedVar = TypedVar String Type
    deriving (Show, Eq, Ord)

type VariantTypes = [Type]

data Access
    = Obj
    | As Access Span [Type]
    | Sel Word32 Span Access
    | ADeref Access
    deriving (Show, Eq, Ord)

type VarBindings = [(TypedVar, Access)]

data DecisionTree
    = DLeaf (VarBindings, Expr)
    | DSwitch Access (Map VariantIx DecisionTree) DecisionTree
    | DSwitchStr Access (Map String DecisionTree) 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 Fun
    | Let Def Expr
    | Match Expr DecisionTree Type
    | Ction Ction
    | Sizeof Type
    | Absurd Type
    deriving (Show)

data Expr = Expr (Maybe SrcPos) Expr'
    deriving Show

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

data Program = Program Defs Datas Externs
    deriving Show


instance TypeAst Type where
    tprim = TPrim
    tconst = TConst
    tfun = TFun
    tbox = TBox

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

instance FreeVars Expr' TypedVar where
    freeVars = fvExpr'


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 (VarDef (lhs, WithPos _ (_, rhs))) (Expr _ e) ->
        Set.union (freeVars rhs) (Set.delete lhs (freeVars e))
    Let (RecDefs ds) (Expr _ e) -> fvLet (unzip (map (second (Fun . snd . unpos)) ds)) e
    Match e dt _ -> Set.union (freeVars e) (fvDecisionTree dt)
    Ction (_, _, _, as) -> Set.unions (map freeVars as)
    Sizeof _t -> Set.empty
    Absurd _ -> Set.empty

fvDecisionTree :: DecisionTree -> Set TypedVar
fvDecisionTree = \case
    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