Skip to content
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
126 changes: 2 additions & 124 deletions src/stdlib/mexpr/monomorphize.mc
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,7 @@ include "mexpr/cmp.mc"
include "mexpr/eq.mc"
include "mexpr/eval.mc"
include "mexpr/pprint.mc"
include "mexpr/resymbolize.mc"
include "mexpr/symbolize.mc"
include "mexpr/type.mc"
include "mexpr/type-check.mc"
Expand Down Expand Up @@ -207,129 +208,6 @@ lang MonomorphizeInstantiate = Monomorphize
| ty -> smap_Type_Type (instantiatePolymorphicType inst) ty
end

lang MonomorphizeResymbolize = Monomorphize
-- Resymbolizes all variables bound inside the provided expression. We use
-- this to ensure function definitions duplicated due to monomorphization end
-- up with distinct symbols.
sem resymbolizeBindings : Expr -> Expr
sem resymbolizeBindings =
| ast -> resymbolizeBindingsExpr (mapEmpty nameCmp) ast

sem resymbolizeBindingsDecl : Map Name Name -> Decl -> (Map Name Name, Decl)
sem resymbolizeBindingsDecl nameMap =
| d -> (nameMap, smap_Decl_Expr (resymbolizeBindingsExpr nameMap) d)
| DeclLet t ->
let body = resymbolizeBindingsExpr nameMap t.body in
let newId = nameSetNewSym t.ident in
let nameMap = mapInsert t.ident newId nameMap in
( nameMap
, DeclLet
{ t with ident = newId
, tyAnnot = resymbolizeBindingsType nameMap t.tyAnnot
, tyBody = resymbolizeBindingsType nameMap t.tyBody
, body = body
}
)
| DeclRecLets t ->
let addNewIdBinding = lam nameMap. lam bind.
let newId = nameSetNewSym bind.ident in
(mapInsert bind.ident newId nameMap, {bind with ident = newId})
in
match mapAccumL addNewIdBinding nameMap t.bindings with (nameMap, bindings) in
let resymbolizeBind = lam bind.
{bind with tyAnnot = resymbolizeBindingsType nameMap bind.tyAnnot,
tyBody = resymbolizeBindingsType nameMap bind.tyBody,
body = resymbolizeBindingsExpr nameMap bind.body}
in
let bindings = map resymbolizeBind bindings in
(nameMap, DeclRecLets {t with bindings = bindings})
| DeclType t ->
let newId = nameSetNewSym t.ident in
let nameMap = mapInsert t.ident newId nameMap in
( nameMap
, DeclType
{ t with ident = newId
, tyIdent = resymbolizeBindingsType nameMap t.tyIdent
}
)
| DeclConDef t ->
let newId = nameSetNewSym t.ident in
let nameMap = mapInsert t.ident newId nameMap in
(nameMap, DeclConDef {t with ident = newId, tyIdent = resymbolizeBindingsType nameMap t.tyIdent})

sem resymbolizeBindingsExpr : Map Name Name -> Expr -> Expr
sem resymbolizeBindingsExpr nameMap =
| TmVar t ->
let newId =
match mapLookup t.ident nameMap with Some newId then newId
else t.ident
in
TmVar {t with ident = newId, ty = resymbolizeBindingsType nameMap t.ty}
| TmLam t ->
let newId = nameSetNewSym t.ident in
let nameMap = mapInsert t.ident newId nameMap in
TmLam {t with ident = newId,
tyAnnot = resymbolizeBindingsType nameMap t.tyAnnot,
tyParam = resymbolizeBindingsType nameMap t.tyParam,
body = resymbolizeBindingsExpr nameMap t.body,
ty = resymbolizeBindingsType nameMap t.ty}
| TmDecl t ->
match resymbolizeBindingsDecl nameMap t.decl with (nameMap, decl) in
let inexpr = resymbolizeBindingsExpr nameMap t.inexpr in
TmDecl {t with decl = decl, inexpr = inexpr}
| TmConApp t ->
let newId =
match mapLookup t.ident nameMap with Some newId then newId
else t.ident
in
TmConApp {t with ident = newId,
body = resymbolizeBindingsExpr nameMap t.body,
ty = resymbolizeBindingsType nameMap t.ty}
| TmMatch t ->
let target = resymbolizeBindingsExpr nameMap t.target in
match resymbolizeBindingsPat nameMap t.pat with (thnNameMap, pat) in
TmMatch {t with target = target, pat = pat,
thn = resymbolizeBindingsExpr thnNameMap t.thn,
els = resymbolizeBindingsExpr nameMap t.els,
ty = resymbolizeBindingsType nameMap t.ty}
| t ->
let t = smap_Expr_Expr (resymbolizeBindingsExpr nameMap) t in
let t = smap_Expr_Type (resymbolizeBindingsType nameMap) t in
let t = smap_Expr_TypeLabel (resymbolizeBindingsType nameMap) t in
withType (resymbolizeBindingsType nameMap (tyTm t)) t

sem resymbolizeBindingsPat : Map Name Name -> Pat -> (Map Name Name, Pat)
sem resymbolizeBindingsPat nameMap =
| PatNamed (t & {ident = PName id}) ->
let newId = nameSetNewSym id in
(mapInsert id newId nameMap, PatNamed {t with ident = PName newId})
| PatSeqEdge (t & {middle = PName id}) ->
let newId = nameSetNewSym id in
(mapInsert id newId nameMap, PatSeqEdge {t with middle = PName newId})
| PatCon t ->
match mapLookup t.ident nameMap with Some newId then
(nameMap, PatCon {t with ident = newId})
else (nameMap, PatCon t)
| p -> smapAccumL_Pat_Pat resymbolizeBindingsPat nameMap p

sem resymbolizeBindingsType : Map Name Name -> Type -> Type
sem resymbolizeBindingsType nameMap =
| TyCon t ->
match mapLookup t.ident nameMap with Some newId then
TyCon {t with ident = newId}
else TyCon t
| TyVar t ->
match mapLookup t.ident nameMap with Some newId then
TyVar {t with ident = newId}
else TyVar t
| TyAll t ->
let newId = nameSetNewSym t.ident in
let nameMap = mapInsert t.ident newId nameMap in
TyAll {t with ident = newId,
ty = resymbolizeBindingsType nameMap t.ty}
| ty -> smap_Type_Type (resymbolizeBindingsType nameMap) ty
end

lang MonomorphizeCollect =
MonomorphizeValidate + MonomorphizeInstantiate + MExprCallGraph + AppTypeUtils

Expand Down Expand Up @@ -618,7 +496,7 @@ lang MonomorphizeCollect =
| ty -> monoError [infoTy ty] "Constructor type does not refer to a known variant type"
end

lang MonomorphizeApply = MonomorphizeInstantiate + MonomorphizeResymbolize + AppTypeUtils
lang MonomorphizeApply = MonomorphizeInstantiate + MExprResymbolize + AppTypeUtils
-- Replaces polymorphic constructs with their monomorphic bindings
-- based on the provided monomorphization environment (bottom-up).
sem applyMonomorphization : MonoEnv -> Expr -> Expr
Expand Down
Loading
Loading