Record erasable args in definitions

This could allow us to actually erase (rather than compile with nil)
although experiments show that has no impact on performance. It is
useful to see, though, and other back ends may benefit.
This commit is contained in:
Edwin Brady 2019-09-19 09:56:19 +01:00
parent 15289b8222
commit a38cce4c90
10 changed files with 76 additions and 13 deletions

View File

@ -98,6 +98,7 @@ modules =
TTImp.Elab.Record, TTImp.Elab.Record,
TTImp.Elab.Rewrite, TTImp.Elab.Rewrite,
TTImp.Elab.Term, TTImp.Elab.Term,
TTImp.Elab.Utils,
TTImp.Interactive.CaseSplit, TTImp.Interactive.CaseSplit,
TTImp.Interactive.ExprSearch, TTImp.Interactive.ExprSearch,
TTImp.Interactive.GenerateDef, TTImp.Interactive.GenerateDef,

View File

@ -159,7 +159,7 @@ mutual
toCExpTm tags n (Bind fc x (Lam _ _ _) sc) toCExpTm tags n (Bind fc x (Lam _ _ _) sc)
= pure $ CLam fc x !(toCExp tags n sc) = pure $ CLam fc x !(toCExp tags n sc)
toCExpTm tags n (Bind fc x (Let Rig0 val _) sc) toCExpTm tags n (Bind fc x (Let Rig0 val _) sc)
= pure $ CLet fc x (CErased fc) !(toCExp tags n sc) = pure $ shrinkCExp (DropCons SubRefl) !(toCExp tags n sc)
toCExpTm tags n (Bind fc x (Let _ val _) sc) toCExpTm tags n (Bind fc x (Let _ val _) sc)
= pure $ CLet fc x !(toCExp tags n val) !(toCExp tags n sc) = pure $ CLet fc x !(toCExp tags n val) !(toCExp tags n sc)
toCExpTm tags n (Bind fc x (Pi c e ty) sc) toCExpTm tags n (Bind fc x (Pi c e ty) sc)

View File

@ -27,7 +27,7 @@ import Data.Buffer
-- TTC files can only be compatible if the version number is the same -- TTC files can only be compatible if the version number is the same
export export
ttcVersion : Int ttcVersion : Int
ttcVersion = 7 ttcVersion = 8
export export
checkTTCVersion : Int -> Int -> Core () checkTTCVersion : Int -> Int -> Core ()

View File

@ -30,9 +30,9 @@ mutual
COp : FC -> PrimFn arity -> Vect arity (CExp vars) -> CExp vars COp : FC -> PrimFn arity -> Vect arity (CExp vars) -> CExp vars
-- Externally defined primitive operations -- Externally defined primitive operations
CExtPrim : FC -> (p : Name) -> List (CExp vars) -> CExp vars CExtPrim : FC -> (p : Name) -> List (CExp vars) -> CExp vars
-- A forced (evaluated) value (TODO: is this right?) -- A forced (evaluated) value
CForce : FC -> CExp vars -> CExp vars CForce : FC -> CExp vars -> CExp vars
-- A delayed value (lazy? TODO: check) -- A delayed value
CDelay : FC -> CExp vars -> CExp vars CDelay : FC -> CExp vars -> CExp vars
-- A case match statement -- A case match statement
CConCase : FC -> (sc : CExp vars) -> List (CConAlt vars) -> Maybe (CExp vars) -> CExp vars CConCase : FC -> (sc : CExp vars) -> List (CConAlt vars) -> Maybe (CExp vars) -> CExp vars
@ -212,6 +212,51 @@ mutual
embedConstAlt : CConstAlt args -> CConstAlt (args ++ vars) embedConstAlt : CConstAlt args -> CConstAlt (args ++ vars)
embedConstAlt (MkConstAlt c sc) = MkConstAlt c (embed sc) embedConstAlt (MkConstAlt c sc) = MkConstAlt c (embed sc)
mutual
-- Shrink the scope of a compiled expression, replacing any variables not
-- in the remaining set with Erased
export
shrinkCExp : SubVars newvars vars -> CExp vars -> CExp newvars
shrinkCExp sub (CLocal fc prf)
= case subElem prf sub of
Nothing => CErased fc
Just (MkVar prf') => CLocal fc prf'
shrinkCExp _ (CRef fc x) = CRef fc x
shrinkCExp sub (CLam fc x sc)
= let sc' = shrinkCExp (KeepCons sub) sc in
CLam fc x sc'
shrinkCExp sub (CLet fc x val sc)
= let sc' = shrinkCExp (KeepCons sub) sc in
CLet fc x (shrinkCExp sub val) sc'
shrinkCExp sub (CApp fc x xs)
= CApp fc (shrinkCExp sub x) (assert_total (map (shrinkCExp sub) xs))
shrinkCExp sub (CCon fc x tag xs)
= CCon fc x tag (assert_total (map (shrinkCExp sub) xs))
shrinkCExp sub (COp fc x xs)
= COp fc x (assert_total (map (shrinkCExp sub) xs))
shrinkCExp sub (CExtPrim fc p xs)
= CExtPrim fc p (assert_total (map (shrinkCExp sub) xs))
shrinkCExp sub (CForce fc x) = CForce fc (shrinkCExp sub x)
shrinkCExp sub (CDelay fc x) = CDelay fc (shrinkCExp sub x)
shrinkCExp sub (CConCase fc sc xs def)
= CConCase fc (shrinkCExp sub sc)
(assert_total (map (shrinkConAlt sub) xs))
(assert_total (map (shrinkCExp sub) def))
shrinkCExp sub (CConstCase fc sc xs def)
= CConstCase fc (shrinkCExp sub sc)
(assert_total (map (shrinkConstAlt sub) xs))
(assert_total (map (shrinkCExp sub) def))
shrinkCExp _ (CPrimVal fc x) = CPrimVal fc x
shrinkCExp _ (CErased fc) = CErased fc
shrinkCExp _ (CCrash fc x) = CCrash fc x
shrinkConAlt : SubVars newvars vars -> CConAlt vars -> CConAlt newvars
shrinkConAlt sub (MkConAlt x tag args sc)
= MkConAlt x tag args (shrinkCExp (subExtend args sub) sc)
shrinkConstAlt : SubVars newvars vars -> CConstAlt vars -> CConstAlt newvars
shrinkConstAlt sub (MkConstAlt x sc) = MkConstAlt x (shrinkCExp sub sc)
mutual mutual
export export
Weaken CExp where Weaken CExp where

View File

@ -162,6 +162,7 @@ record GlobalDef where
location : FC location : FC
fullname : Name -- original unresolved name fullname : Name -- original unresolved name
type : ClosedTerm type : ClosedTerm
eraseArgs : List Nat -- which argument positions to erase at runtime
multiplicity : RigCount multiplicity : RigCount
vars : List Name -- environment name is defined in vars : List Name -- environment name is defined in
visibility : Visibility visibility : Visibility
@ -422,7 +423,7 @@ export
newDef : FC -> Name -> RigCount -> List Name -> newDef : FC -> Name -> RigCount -> List Name ->
ClosedTerm -> Visibility -> Def -> GlobalDef ClosedTerm -> Visibility -> Def -> GlobalDef
newDef fc n rig vars ty vis def newDef fc n rig vars ty vis def
= MkGlobalDef fc n ty rig vars vis unchecked [] empty False False False def = MkGlobalDef fc n ty [] rig vars vis unchecked [] empty False False False def
Nothing [] Nothing []
public export public export
@ -817,7 +818,7 @@ addBuiltin : {auto x : Ref Ctxt Defs} ->
Name -> ClosedTerm -> Totality -> Name -> ClosedTerm -> Totality ->
PrimFn arity -> Core () PrimFn arity -> Core ()
addBuiltin n ty tot op addBuiltin n ty tot op
= do addDef n (MkGlobalDef emptyFC n ty RigW [] Public tot = do addDef n (MkGlobalDef emptyFC n ty [] RigW [] Public tot
[Inline] empty False False True (Builtin op) [Inline] empty False False True (Builtin op)
Nothing []) Nothing [])
pure () pure ()

View File

@ -795,6 +795,12 @@ subExtend : (ns : List Name) -> SubVars xs ys -> SubVars (ns ++ xs) (ns ++ ys)
subExtend [] sub = sub subExtend [] sub = sub
subExtend (x :: xs) sub = KeepCons (subExtend xs sub) subExtend (x :: xs) sub = KeepCons (subExtend xs sub)
export
subInclude : (ns : List Name) -> SubVars xs ys -> SubVars (xs ++ ns) (ys ++ ns)
subInclude ns SubRefl = SubRefl
subInclude ns (DropCons p) = DropCons (subInclude ns p)
subInclude ns (KeepCons p) = KeepCons (subInclude ns p)
mutual mutual
export export
shrinkBinder : Binder (Term vars) -> SubVars newvars vars -> shrinkBinder : Binder (Term vars) -> SubVars newvars vars ->

View File

@ -846,6 +846,7 @@ TTC GlobalDef where
when (isUserName (fullname gdef)) $ when (isUserName (fullname gdef)) $
do toBuf b (location gdef) do toBuf b (location gdef)
toBuf b (type gdef) toBuf b (type gdef)
toBuf b (eraseArgs gdef)
toBuf b (multiplicity gdef) toBuf b (multiplicity gdef)
toBuf b (vars gdef) toBuf b (vars gdef)
toBuf b (visibility gdef) toBuf b (visibility gdef)
@ -863,17 +864,17 @@ TTC GlobalDef where
let refs = map fromList refsList let refs = map fromList refsList
if isUserName name if isUserName name
then do loc <- fromBuf b; then do loc <- fromBuf b;
ty <- fromBuf b; mul <- fromBuf b ty <- fromBuf b; eargs <- fromBuf b;
vars <- fromBuf b mul <- fromBuf b; vars <- fromBuf b
vis <- fromBuf b; tot <- fromBuf b vis <- fromBuf b; tot <- fromBuf b
fl <- fromBuf b fl <- fromBuf b
inv <- fromBuf b inv <- fromBuf b
c <- fromBuf b c <- fromBuf b
sc <- fromBuf b sc <- fromBuf b
pure (MkGlobalDef loc name ty mul vars vis pure (MkGlobalDef loc name ty eargs mul vars vis
tot fl refs inv c True def cdef sc) tot fl refs inv c True def cdef sc)
else do let fc = emptyFC else do let fc = emptyFC
pure (MkGlobalDef fc name (Erased fc) pure (MkGlobalDef fc name (Erased fc) []
RigW [] Public unchecked [] refs RigW [] Public unchecked [] refs
False False True def cdef []) False False True def cdef [])

View File

@ -52,6 +52,7 @@ showInfo (n, idx, d)
= do coreLift $ putStrLn (show (fullname d) ++ " ==> " ++ = do coreLift $ putStrLn (show (fullname d) ++ " ==> " ++
show !(toFullNames (definition d))) show !(toFullNames (definition d)))
coreLift $ putStrLn (show (multiplicity d)) coreLift $ putStrLn (show (multiplicity d))
coreLift $ putStrLn ("Erasable args: " ++ show (eraseArgs d))
case compexpr d of case compexpr d of
Nothing => pure () Nothing => pure ()
Just expr => coreLift $ putStrLn ("Compiled: " ++ show expr) Just expr => coreLift $ putStrLn ("Compiled: " ++ show expr)

View File

@ -11,6 +11,7 @@ import Core.Value
import TTImp.BindImplicits import TTImp.BindImplicits
import TTImp.Elab.Check import TTImp.Elab.Check
import TTImp.Elab.Utils
import TTImp.Elab import TTImp.Elab
import TTImp.TTImp import TTImp.TTImp
@ -201,8 +202,9 @@ processData {vars} eopts nest env fc vis (MkImpData dfc n_in ty_raw opts cons_ra
addToSave n addToSave n
log 10 $ "Saving from " ++ show n ++ ": " ++ show (keys (getMetas ty)) log 10 $ "Saving from " ++ show n ++ ": " ++ show (keys (getMetas ty))
let connames = map conName cons
when (not (NoHints `elem` opts)) $ when (not (NoHints `elem` opts)) $
traverse_ (\x => addHintFor fc (Resolved tidx) x True False) (map conName cons) traverse_ (\x => addHintFor fc (Resolved tidx) x True False) connames
pure () traverse_ updateErasable (Resolved tidx :: connames)

View File

@ -12,6 +12,7 @@ import Core.Value
import TTImp.BindImplicits import TTImp.BindImplicits
import TTImp.Elab.Check import TTImp.Elab.Check
import TTImp.Elab.Utils
import TTImp.Elab import TTImp.Elab
import TTImp.TTImp import TTImp.TTImp
@ -101,7 +102,12 @@ processType {vars} eopts nest env fc rig vis opts (MkImpTy tfc n_in ty_raw)
-- TODO: Check name visibility -- TODO: Check name visibility
def <- initDef n env ty opts def <- initDef n env ty opts
addDef (Resolved idx) (newDef fc n rig vars (abstractEnvType tfc env ty) vis def) let fullty = abstractEnvType tfc env ty
erased <- findErased fullty
addDef (Resolved idx)
(record { eraseArgs = erased }
(newDef fc n rig vars fullty vis def))
-- Flag it as checked, because we're going to check the clauses -- Flag it as checked, because we're going to check the clauses
-- from the top level. -- from the top level.
-- But, if it's a case block, it'll be checked as part of the top -- But, if it's a case block, it'll be checked as part of the top