From 67d1e54ffbed46ece8d227fca7770e643380e8aa Mon Sep 17 00:00:00 2001 From: Steve Dunham Date: Tue, 24 Jun 2025 20:59:36 -0700 Subject: [PATCH] Seperate CAppRef constructor for top level apps --- Makefile | 2 +- src/Lib/Compile.newt | 6 ++++-- src/Lib/CompileExp.newt | 36 ++++++++++++++++-------------------- src/Lib/TCO.newt | 11 ++++++----- 4 files changed, 27 insertions(+), 28 deletions(-) diff --git a/Makefile b/Makefile index 0e63b90..bf09e87 100644 --- a/Makefile +++ b/Makefile @@ -38,7 +38,7 @@ newt2.js: newt.js $(RUNJS) newt.js src/Main.newt -o newt2.js newt3.js: newt2.js - rm -f build/* + -rm build/* time $(RUNJS) newt2.js src/Main.newt -o newt3.js cmp newt2.js newt3.js diff --git a/src/Lib/Compile.newt b/src/Lib/Compile.newt index a975b18..9a59009 100644 --- a/src/Lib/Compile.newt +++ b/src/Lib/Compile.newt @@ -162,7 +162,7 @@ termToJS env (CConstr nm args) f = go args 0 (\ args => f $ LitObject (("tag", L go : ∀ e. List CExp -> Int -> (List (String × JSExp) -> JSStmt e) -> JSStmt e go Nil ix k = k Nil go (t :: ts) ix k = termToJS env t $ \ t' => go ts (ix + 1) $ \ args => k $ ("h\{show ix}", t') :: args -termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args Lin f)) -- (f (Apply t' args')))) +termToJS env (CAppRef nm args etas) f = termToJS env (CRef nm) (\ t' => (argsToJS t' args Lin f)) where etaExpand : JSEnv -> Nat -> SnocList JSExp -> JSExp -> JSExp etaExpand env Z args tm = Apply tm (args <>> Nil) @@ -176,6 +176,7 @@ termToJS env (CApp t args etas) f = termToJS env t (\ t' => (argsToJS t' args Li -- k (acc <>> Nil) argsToJS tm (x :: xs) acc k = termToJS env x (\ x' => argsToJS tm xs (acc :< x') k) +termToJS env (CApp t arg) f = termToJS env t (\ t' => termToJS env arg (\arg' => f (Apply t' (arg' :: Nil)))) termToJS {e} env (CCase t alts) f = -- need to assign the scrutinee to a variable (unless it is a var already?) @@ -349,7 +350,8 @@ sortedNames defs qn = go Nil Nil qn getNames : List QName → CExp → List QName getNames acc (CLam _ t) = getNames acc t getNames acc (CFun _ t) = getNames acc t - getNames acc (CApp t ts _) = foldl getNames acc (t :: ts) + getNames acc (CAppRef nm ts _) = foldl getNames (nm :: acc) ts -- (CRef nm :: ts) + getNames acc (CApp t u) = getNames (getNames acc t) u getNames acc (CCase t alts) = foldl getNames acc $ t :: map getBody alts getNames acc (CRef qn) = qn :: acc getNames acc (CLet _ t u) = getNames (getNames acc t) u diff --git a/src/Lib/CompileExp.newt b/src/Lib/CompileExp.newt index 764f5e9..525a8d4 100644 --- a/src/Lib/CompileExp.newt +++ b/src/Lib/CompileExp.newt @@ -1,10 +1,3 @@ --- 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 @@ -35,7 +28,8 @@ data CExp : U where -- How is CLam different from CFun with one arg? CLam : Name -> CExp -> CExp CFun : List Name -> CExp -> CExp - CApp : CExp -> List CExp -> Int -> CExp + CAppRef : QName -> List CExp -> Int -> CExp + CApp : CExp -> CExp -> CExp CCase : CExp -> List CAlt -> CExp CRef : QName -> CExp CMeta : Int -> CExp @@ -78,21 +72,22 @@ any f Nil = False any f (x :: xs) = if f x then True else any f xs -- apply an expression at an arity to a list of args --- CApp will specify any missing args, for eta conversion later +-- CAppRef will specify any missing args, for eta conversion later -- and any extra args get individual CApp. -apply : CExp -> List CExp -> SnocList CExp -> Nat -> M CExp +apply : QName -> 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) + pure $ CAppRef 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 +apply t ts acc Z = case acc of + -- drop zero arg call + Lin => go (CRef t) ts + _ => go (CAppRef 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 + go t (arg :: args) = go (CApp t arg) args lookupDef : {{Ref2 Defs St}} → FC → QName → M Def lookupDef fc nm = do @@ -117,7 +112,7 @@ compileTerm t@(Ref fc nm@(QN _ tag)) = do Just (DCon SuccCon _ _) => pure $ CLam "x" $ CPrimOp "+" (CLit $ LInt 1) (CBnd 0) _ => pure $ CRef nm - _ => apply (CRef nm) Nil Lin arity + _ => apply nm Nil Lin arity compileTerm (Meta fc k) = error fc "Compiling meta \{show k}" compileTerm (Lam _ nm _ _ t) = CLam nm <$> compileTerm t @@ -125,19 +120,20 @@ 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 + -- pure $ CAppRef "Meta\{show k}" Nil 0 (t@(Ref fc nm), args) => do defs <- getRef Defs args' <- traverse compileTerm args arity <- arityForName fc nm case the (Maybe Def) $ lookupMap' nm defs of Just (DCon SuccCon _ _) => applySucc args' - _ => apply (CRef nm) args' Lin arity + _ => apply nm args' Lin arity + -- REVIEW maybe we want a different constructor for non-Ref applications? (t, args) => do debug $ \ _ => "apply other \{render 90 $ pprint Nil t}" t' <- compileTerm t args' <- traverse compileTerm args - apply t' args' Lin Z + pure $ foldl CApp t' args' where applySucc : List CExp → M CExp applySucc Nil = pure $ CLam "x" $ CPrimOp "+" (CLit $ LInt 1) (CBnd 0) @@ -147,7 +143,7 @@ compileTerm (UU _) = pure $ CRef (QN Nil "U") compileTerm (Pi _ nm icit rig t u) = do t' <- compileTerm t u' <- compileTerm u - pure $ CApp (CRef (QN Nil "PiType")) (t' :: CLam nm u' :: Nil) 0 + pure $ CAppRef (QN Nil "PiType") (t' :: CLam nm u' :: Nil) 0 compileTerm (Case fc t alts) = do t' <- compileTerm t alts' <- for alts $ \case diff --git a/src/Lib/TCO.newt b/src/Lib/TCO.newt index 2f614ad..fa85315 100644 --- a/src/Lib/TCO.newt +++ b/src/Lib/TCO.newt @@ -19,7 +19,7 @@ import Data.SortedMap -- Find names of applications in tail position tailNames : CExp → List QName -tailNames (CApp (CRef name) args 0) = name :: Nil +tailNames (CAppRef nm args n) = nm :: Nil tailNames (CCase _ alts) = join $ map altTailNames alts where altTailNames : CAlt → List QName @@ -32,8 +32,9 @@ tailNames (CConstr _ args) = Nil tailNames (CBnd _) = Nil tailNames (CFun _ tm) = tailNames tm tailNames (CLam _ _) = Nil -tailNames (CApp (CRef nm) args n) = nm :: Nil -tailNames (CApp t args n) = Nil +-- should not happen, FIXME +tailNames (CAppRef t args n) = Nil +tailNames (CApp t u) = Nil tailNames (CRef _) = Nil tailNames CErased = Nil tailNames (CLit _) = Nil @@ -44,7 +45,7 @@ tailNames (CPrimOp _ _ _) = Nil -- rewrite tail calls to return an object rewriteTailCalls : List QName → CExp → CExp rewriteTailCalls nms tm = case tm of - CApp (CRef nm) args 0 => + CAppRef nm args 0 => if elem nm nms then CConstr (show nm) args else CConstr "return" (tm :: Nil) @@ -76,7 +77,7 @@ doOptimize fns = do mkWrap recName (qn, CFun args _) = do let arglen = length' args let arg = CConstr (show qn) $ map (\k => CBnd (arglen - k - 1)) (range 0 arglen) - let body = CApp (CRef bouncer) (CRef recName :: arg :: Nil) 0 + let body = CAppRef bouncer (CRef recName :: arg :: Nil) 0 pure $ (qn, CFun args body) mkWrap _ (qn, _) = error emptyFC "error in mkWrap: \{show qn} not a CFun"