141 lines
4.6 KiB
Agda
141 lines
4.6 KiB
Agda
-- First pass of compilation
|
|
-- - work out arities and fully apply functions / constructors (currying)
|
|
-- currying is problemmatic because we need to insert lambdas (η-expand) and
|
|
-- it breaks all of the de Bruijn indices
|
|
-- - expand metas (this is happening earlier)
|
|
-- - erase stuff (there is another copy that essentially does the same thing)
|
|
-- I could make names unique (e.q. on lambdas), but I might want that to vary per backend?
|
|
module Lib.CompileExp
|
|
|
|
import Prelude
|
|
import Lib.Common
|
|
import Lib.Types -- Name / Tm
|
|
import Lib.TopContext
|
|
import Lib.Prettier
|
|
import Lib.Util
|
|
import Lib.Ref2
|
|
import Data.SortedMap
|
|
|
|
CExp : U
|
|
|
|
data CAlt : U where
|
|
CConAlt : String -> List String -> CExp -> CAlt
|
|
-- REVIEW keep var name?
|
|
CDefAlt : CExp -> CAlt
|
|
-- literal
|
|
CLitAlt : Literal -> CExp -> CAlt
|
|
|
|
data CExp : U where
|
|
CBnd : Int -> CExp
|
|
CLam : Name -> CExp -> CExp
|
|
CFun : List Name -> CExp -> CExp
|
|
CApp : CExp -> List CExp -> Int -> CExp
|
|
CCase : CExp -> List CAlt -> CExp
|
|
CRef : Name -> CExp
|
|
CMeta : Int -> CExp
|
|
CLit : Literal -> CExp
|
|
CLet : Name -> CExp -> CExp -> CExp
|
|
CLetRec : Name -> CExp -> CExp -> CExp
|
|
CErased : CExp
|
|
|
|
-- I'm counting Lam in the term for arity. This matches what I need in
|
|
-- code gen.
|
|
|
|
lamArity : Tm -> Nat
|
|
lamArity (Lam _ _ _ _ t) = S (lamArity t)
|
|
lamArity _ = Z
|
|
|
|
|
|
|
|
-- This is how much we want to curry at top level
|
|
-- leading lambda Arity is used for function defs and metas
|
|
-- TODO - figure out how this will work with erasure
|
|
arityForName : {{Ref2 Defs St}} → FC -> QName -> M Nat
|
|
arityForName fc nm = do
|
|
defs <- getRef Defs
|
|
case lookupMap' nm defs of
|
|
Nothing => error fc "Name \{show nm} not in scope"
|
|
(Just Axiom) => pure Z
|
|
(Just (TCon arity strs)) => pure $ cast arity
|
|
(Just (DCon k str)) => pure $ cast k
|
|
(Just (Fn t)) => pure $ lamArity t
|
|
(Just (PrimTCon arity)) => pure $ cast arity
|
|
(Just (PrimFn t arity used)) => pure arity
|
|
|
|
|
|
compileTerm : {{Ref2 Defs St}} → Tm -> M CExp
|
|
|
|
-- need to eta out extra args, fill in the rest of the apps
|
|
apply : CExp -> List CExp -> SnocList CExp -> Nat -> M CExp
|
|
-- out of args, make one up (fix that last arg)
|
|
apply t Nil acc (S k) = pure $ CApp t (acc <>> Nil) (1 + cast k)
|
|
apply t (x :: xs) acc (S k) = apply t xs (acc :< x) k
|
|
-- once we hit zero, we fold the rest
|
|
apply t ts acc Z = go (CApp t (acc <>> Nil) 0) ts
|
|
where
|
|
go : CExp -> List CExp -> M CExp
|
|
-- drop zero arg call
|
|
go (CApp t Nil 0) args = go t args
|
|
go t Nil = pure t
|
|
go t (arg :: args) = go (CApp t (arg :: Nil) 0) args
|
|
|
|
compileTerm (Bnd _ k) = pure $ CBnd k
|
|
-- need to eta expand to arity
|
|
compileTerm t@(Ref fc nm) = do
|
|
arity <- arityForName fc nm
|
|
case arity of
|
|
-- we don't need to curry functions that take one argument
|
|
(S Z) => pure $ CRef (show nm)
|
|
_ => apply (CRef (show nm)) Nil Lin arity
|
|
|
|
compileTerm (Meta _ k) = pure $ CRef "meta$\{show k}" -- FIXME
|
|
compileTerm (Lam _ nm _ _ t) = CLam nm <$> compileTerm t
|
|
compileTerm tm@(App _ _ _) = case funArgs tm of
|
|
(Meta _ k, args) => do
|
|
error (getFC tm) "Compiling an unsolved meta \{show tm}"
|
|
-- info (getFC tm) "Compiling an unsolved meta \{show tm}"
|
|
-- pure $ CApp (CRef "Meta\{show k}") Nil 0
|
|
(t@(Ref fc nm), args) => do
|
|
args' <- traverse compileTerm args
|
|
arity <- arityForName fc nm
|
|
apply (CRef (show nm)) args' Lin arity
|
|
(t, args) => do
|
|
debug $ \ _ => "apply other \{render 90 $ pprint Nil t}"
|
|
t' <- compileTerm t
|
|
args' <- traverse compileTerm args
|
|
apply t' args' Lin Z
|
|
-- error (getFC t) "Don't know how to apply \{showTm t}"
|
|
compileTerm (UU _) = pure $ CRef "U"
|
|
compileTerm (Pi _ nm icit rig t u) = do
|
|
t' <- compileTerm t
|
|
u' <- compileTerm u
|
|
pure $ CApp (CRef "PiType") (t' :: CLam nm u' :: Nil) 0
|
|
compileTerm (Case _ t alts) = do
|
|
t' <- compileTerm t
|
|
alts' <- for alts $ \case
|
|
CaseDefault tm => CDefAlt <$> compileTerm tm
|
|
-- we use the base name for the tag, some primitives assume this
|
|
CaseCons (QN ns nm) args tm => CConAlt nm args <$> compileTerm tm
|
|
CaseLit lit tm => CLitAlt lit <$> compileTerm tm
|
|
pure $ CCase t' alts'
|
|
compileTerm (Lit _ lit) = pure $ CLit lit
|
|
compileTerm (Let _ nm t u) = do
|
|
t' <- compileTerm t
|
|
u' <- compileTerm u
|
|
pure $ CLet nm t' u'
|
|
compileTerm (LetRec _ nm _ t u) = do
|
|
t' <- compileTerm t
|
|
u' <- compileTerm u
|
|
pure $ CLetRec nm t' u'
|
|
compileTerm (Erased _) = pure CErased
|
|
|
|
compileFun : {{Ref2 Defs St}} → Tm -> M CExp
|
|
compileFun tm = go tm Lin
|
|
where
|
|
go : Tm -> SnocList String -> M CExp
|
|
go (Lam _ nm _ _ t) acc = go t (acc :< nm)
|
|
go tm Lin = compileTerm tm
|
|
go tm args = CFun (args <>> Nil) <$> compileTerm tm
|
|
|
|
|