Cons/Nil optimization for scheme backend

prim.ss

@@ -38,22 +38,9 @@
 ;; REVIEW returns #f for failure
 (define Prelude.stringToInt string->number)
 
-;; coerce scheme list to newt
+(define (Prelude.unpack str) (string->list str))
-(define (list->List xs)
+(define (Prelude.pack cs) (list->string cs))
-  (define (go acc xs)
+(define (Prelude.fastConcat strings) (apply string-append strings))
-    (if (null? xs) acc
-        (go ($Cons #f (car xs) acc) (cdr xs))))
-  (go ($Nil #f) (reverse xs)))
-
-(define (List->list xs)
-  (define (go acc xs)
-    (if (= 0 (vector-ref xs 0)) (reverse acc)
-        (go (cons (vector-ref xs 2) acc) (vector-ref xs 3))))
-  (go '() xs))
-
-(define (Prelude.unpack str) (list->List (string->list str)))
-(define (Prelude.pack cs) (list->string (List->list cs)))
-(define (Prelude.fastConcat strings) (apply string-append (List->list strings)))
 
 (define (Prelude.isPrefixOf pfx str)
         (string=? pfx (substring str 0 (string-length pfx))))
@@ -94,4 +81,4 @@
     (if (<= n m)
         (string=? sfx (substring s (- m n) m))
         #f)))
-(define (Node.getArgs w) ($IORes (list->List (command-line)) w))
+(define (Node.getArgs w) ($IORes (command-line) w))

src/LSP.newt

@@ -67,9 +67,8 @@ lspFileSource = do
 
 updateFile : String → String → Unit
 updateFile fn src = unsafePerformIO $ do
-    st <- readIORef state
     modifyIORef state [ files $= updateMap fn src ]
-    let st = the LSPState $ [ files $= updateMap fn src ] st
+    st <- readIORef state
     let (base,modName) = decomposeName fn
     Right (ctx,_) <- (invalidateModule modName).runM st.topContext
         | _ => writeIORef state st

src/Lib/CompileExp.newt

@@ -17,7 +17,7 @@ import Data.SortedMap
 CExp : U
 
 data CAlt : U where
-  CConAlt : Nat → String → ConInfo → List String → CExp → CAlt
+  CConAlt : Nat → String → ConInfo → List String → List Quant → CExp → CAlt
   -- REVIEW keep var name?
   CDefAlt : CExp -> CAlt
   -- literal
@@ -43,7 +43,7 @@ data CExp : U where
   CLoop : List CExp → List Quant → CExp
   CErased : CExp
   -- Data / type constructor
-  CConstr : Nat → Name → List CExp → List Quant → CExp
+  CConstr : Nat → Name → List CExp → List Quant → ConInfo → CExp
   -- Raw javascript for `pfunc`
   CRaw : String -> List QName -> CExp
   -- Need this for magic Nat
@@ -101,7 +101,7 @@ lookupDef fc nm = do
     Just def => pure def
 
 getBody : CAlt → CExp
-getBody (CConAlt _ _ _ _ t) = t
+getBody (CConAlt _ _ _ _ _ t) = t
 getBody (CLitAlt _ t) = t
 getBody (CDefAlt t) = t
 
@@ -137,6 +137,21 @@ compileTerm tm@(App _ _ _) = case funArgs tm of
         arity <- arityForName fc nm
         case lookupMap' nm defs : Maybe Def of
           Just (DCon _ SuccCon _ _) => applySucc args'
+          -- Inline these two, maybe all of them?
+          Just (DCon tag ConsCon qs _) =>
+            if length' qs == length' args
+              then pure $ CConstr tag nm.baseName args' qs ConsCon
+              else apply nm args' arity
+          Just (DCon tag NilCon qs _) =>
+            if length' qs == length' args
+              then pure $ CConstr tag nm.baseName args' qs NilCon
+              else apply nm args' arity
+          -- REVIEW Slower for JS, faster for scheme. (2.88 vs 3.01)
+          -- but all of the "JS" diff is code gen?
+          -- Just (DCon tag info qs _) =>
+          --   if length' qs == length' args
+          --     then pure $ CConstr tag nm.baseName args' qs info
+          --     else apply nm args' arity
           _ => apply nm args' arity
   -- REVIEW maybe we want a different constructor for non-Ref applications?
   (t, args) => do
@@ -164,25 +179,25 @@ compileTerm (Case fc t alts) = do
       defs <- getRef Defs
       def <- lookupDef emptyFC qn
       case def of
-        DCon ix info _ _ => CConAlt ix nm info args <$> compileTerm tm
+        DCon ix info qs _ => CConAlt ix nm info args qs <$> compileTerm tm
-        _ => error fc "\{show nm} is not constructor"
+        _ => error fc "\{show nm} is not a data constructor"
 
     CaseLit lit tm => CLitAlt lit <$> compileTerm tm
   pure $ CCase t' $ fancyCons t' alts'
   where
     numAltP : CAlt → Bool
-    numAltP (CConAlt _ _ SuccCon _ _) = True
+    numAltP (CConAlt _ _ SuccCon _ _ _) = True
-    numAltP (CConAlt _ _ ZeroCon _ _) = True
+    numAltP (CConAlt _ _ ZeroCon _ _ _) = True
     numAltP _ = False
 
     enumAlt : CAlt → CAlt
-    enumAlt (CConAlt ix nm EnumCon args tm) = CLitAlt (LInt $ cast ix) tm
+    enumAlt (CConAlt ix nm EnumCon args _ tm) = CLitAlt (LInt $ cast ix) tm
-    enumAlt (CConAlt ix nm FalseCon args tm) = CLitAlt (LBool False) tm
+    enumAlt (CConAlt ix nm FalseCon args _ tm) = CLitAlt (LBool False) tm
-    enumAlt (CConAlt ix nm TrueCon args tm) = CLitAlt (LBool True) tm
+    enumAlt (CConAlt ix nm TrueCon args _ tm) = CLitAlt (LBool True) tm
     enumAlt alt = alt
 
     isInfo : ConInfo → CAlt → Bool
-    isInfo needle (CConAlt _ _  info _ _)  = needle == info
+    isInfo needle (CConAlt _ _  info _ _ _)  = needle == info
     isInfo _ _ = False
 
     isDef : CAlt → Bool
@@ -193,7 +208,7 @@ compileTerm (Case fc t alts) = do
     doNumCon : CExp → List CAlt → List CAlt
     doNumCon sc alts =
       let zeroAlt = case find (isInfo ZeroCon) alts of
-            Just (CConAlt _ _ _ _ tm) => CLitAlt (LInt 0) tm :: Nil
+            Just (CConAlt _ _ _ _ _ tm) => CLitAlt (LInt 0) tm :: Nil
             Just tm => fatalError "ERROR zeroAlt mismatch \{debugStr tm}"
             _ => case find isDef alts of
                   Just (CDefAlt tm) => CLitAlt (LInt 0) tm :: Nil
@@ -201,7 +216,7 @@ compileTerm (Case fc t alts) = do
                   _ => Nil
       in
       let succAlt = case find (isInfo SuccCon) alts of
-            Just (CConAlt _ _ _ _ tm) => CDefAlt (CLet "x" (CPrimOp "-" sc (CLit $ LInt 1)) tm) :: Nil
+            Just (CConAlt _ _ _ _ _ tm) => CDefAlt (CLet "x" (CPrimOp "-" sc (CLit $ LInt 1)) tm) :: Nil
             Just tm => fatalError "ERROR succAlt mismatch \{debugStr tm}"
             _ => case find isDef alts of
               Just alt => alt :: Nil
@@ -244,13 +259,13 @@ compileDCon : Nat → QName → ConInfo → List Quant → CExp
 compileDCon ix (QN _ nm) EnumCon Nil = CLit $ LInt $ cast ix
 compileDCon ix (QN _ nm) TrueCon Nil = CLit $ LBool True
 compileDCon ix (QN _ nm) FalseCon Nil = CLit $ LBool False
-compileDCon ix (QN _ nm) info Nil = CConstr ix nm Nil Nil
+compileDCon ix (QN _ nm) info Nil = CConstr ix nm Nil Nil info
 compileDCon ix (QN _ nm) info arity =
   -- so we're fully applying this here, but dropping the args later?
   -- The weird thing is that lambdas need the
   let args = mkArgs Z arity
       alen = length' arity
-  in CFun args $ CConstr ix nm (map (\k => CBnd $ alen - k - 1) (range 0 alen)) arity
+  in CFun args $ CConstr ix nm (map (\k => CBnd $ alen - k - 1) (range 0 alen)) arity info
   where
     mkArgs : Nat → List Quant → List (Quant × String)
     mkArgs k (quant :: args) = (quant, "h\{show k}") :: mkArgs (S k) args

src/Lib/CompileJS.newt

@@ -221,7 +221,7 @@ termToJS env (CLetRec nm t u) f =
   in case termToJS env' t (JAssign nm') of
     (JAssign _ exp) => JSnoc (JConst nm' exp) (termToJS env' u f)
     t' => JSnoc (JLet nm' t') (termToJS env' u f)
-termToJS env (CConstr ix _ args qs) f = go args qs 0 (\ args => f $ LitObject (("tag", LitInt (cast ix)) :: args))
+termToJS env (CConstr ix _ args qs info) f = go args qs 0 (\ args => f $ LitObject (("tag", LitInt (cast ix)) :: args))
   where
     go : ∀ e. List CExp -> List Quant -> Int -> (List (String × JSExp) -> JSStmt e) -> JSStmt e
     go (t :: ts) (Many :: qs) ix k = termToJS env t $ \ t' => go ts qs (ix + 1) $ \ args => k $ ("h\{show ix}", t') :: args
@@ -298,7 +298,7 @@ termToJS {e} env (CCase t alts) f =
     tertiary sc t f k = JIfThen sc t f
 
     termToJSAlt : JSEnv -> JSExp -> CAlt -> JAlt
-    termToJSAlt env nm (CConAlt ix name info args u) = JConAlt ix (termToJS (conAltEnv nm 0 env args) u f)
+    termToJSAlt env nm (CConAlt ix name info args qs u) = JConAlt ix (termToJS (conAltEnv nm 0 env args) u f)
     -- intentionally reusing scrutinee name here
     termToJSAlt env nm (CDefAlt u) = JDefAlt (termToJS  (env) u f)
     termToJSAlt env nm (CLitAlt lit u) = JLitAlt (litToJS lit) (termToJS env u f)
@@ -306,13 +306,13 @@ termToJS {e} env (CCase t alts) f =
     getArgs : CAlt → List String
     getArgs (CDefAlt _) = Nil
     getArgs (CLitAlt args _) = Nil
-    getArgs (CConAlt _ _ _ args _) = args
+    getArgs (CConAlt _ _ _ args qs _) = args
 
     maybeCaseStmt : JSEnv -> JSExp -> List CAlt -> JSStmt e
     -- deleteT23 does this...
     maybeCaseStmt env sc (CDefAlt u :: Nil) = (termToJS env u f)
     -- If there is a single alt, assume it matched
-    maybeCaseStmt env sc ((CConAlt _ _ info args u) :: Nil) = (termToJS (conAltEnv sc 0 env args) u f)
+    maybeCaseStmt env sc ((CConAlt _ _ info args qs u) :: Nil) = (termToJS (conAltEnv sc 0 env args) u f)
     maybeCaseStmt env sc alts@(CLitAlt _ _  :: _) =
         (JCase sc (map (termToJSAlt env sc) alts))
     maybeCaseStmt env sc alts = case alts of
@@ -322,7 +322,7 @@ termToJS {e} env (CCase t alts) f =
               e' = termToJS env (getBody alt) f
           in if b then tertiary sc t' e' f else tertiary sc e' t' f
         -- two branch alt becomes tertiary operator
-        CConAlt ix name info args t :: alt :: Nil =>
+        CConAlt ix name info args qs t :: alt :: Nil =>
           let cond = (JPrimOp "==" (Dot sc "tag") (LitInt $ cast ix))
               t' = termToJS (conAltEnv sc 0 env args) t f
               u' = termToJS (conAltEnv sc 0 env $ getArgs alt) (getBody alt) f
@@ -496,7 +496,7 @@ sortedNames defs names =
   map snd $ filter (not ∘ fst) $ foldl (go Nil) Nil $ map (True,) names
   where
     getBody : CAlt → CExp
-    getBody (CConAlt _ _ _ _ t) = t
+    getBody (CConAlt _ _ _ _ _ t) = t
     getBody (CLitAlt _ t) = t
     getBody (CDefAlt t) = t
 
@@ -523,7 +523,7 @@ sortedNames defs names =
     getNames deep acc (CRef qn) = (deep, qn) :: acc
     getNames deep acc (CLet _ t u) = getNames deep (getNames deep acc t) u
     getNames deep acc (CLetRec _ t u) = getNames deep (getNames deep acc t) u
-    getNames deep acc (CConstr _ _ ts _) = foldl (getNames deep) acc ts
+    getNames deep acc (CConstr _ _ ts _ info) = foldl (getNames deep) acc ts
     -- if the CRaw is called, then the deps are called
     getNames deep acc (CRaw _ deps) = map (_,_ deep) deps ++ acc
     -- wrote these out so I get an error when I add a new constructor

src/Lib/CompileScheme.newt

@@ -18,6 +18,7 @@ import Data.SortedMap
 import Data.IORef
 import Data.SnocList
 
+-- FIXME SnocList
 SCEnv : U
 SCEnv = List String
 
@@ -64,6 +65,12 @@ scmName qn = scmIdent $ show qn
 
 cexpToScm : SCEnv → CExp → String
 
+argsToScm : SCEnv → List CExp → List Quant → List String
+argsToScm env Nil Nil = Nil
+argsToScm env (e :: es) (Many :: qs) = cexpToScm env e :: argsToScm env es qs
+argsToScm env (e :: es) (Zero :: qs) = argsToScm env es qs
+argsToScm env _ _ = fatalError "Arg count mismatch"
+
 withVar : SCEnv → CExp → (String → String) → String
 -- don't rebind a variable
 withVar env (CBnd n) f = f $ getEnv n env
@@ -117,16 +124,54 @@ cexpToScm env (CCase sc alts) = do
       (arg', env') => let ix = 1 + snoclen' lets
         in conAlt env' nm (lets :< "(\{arg'} (vector-ref \{nm} \{show ix}))") args body
 
+    nilAlt : SCEnv → List Quant → CExp → String
+    nilAlt env Nil body = cexpToScm env body
+    nilAlt env (Zero :: qs) body = nilAlt ("#f" :: env) qs body
+    nilAlt env (Many :: qs) body = fatalError "Non-empty field on nil constructor"
+
+    consAlt' : SCEnv → List String → List Quant → CExp → String
+    consAlt' env nms Nil body = cexpToScm env body
+    consAlt' env nms (Zero :: qs) body = consAlt' ("#f" :: env) nms qs body
+    consAlt' env Nil (Many :: qs) body = fatalError "Too many fields on cons constructor"
+    consAlt' env (nm :: nms) (Many :: qs) body = consAlt' (nm :: env) nms qs body
+
+    consAlt : SCEnv → String → List Quant → CExp → String
+    consAlt env nm qs body = consAlt' env ("(car \{nm})" :: "(cdr \{nm})" :: Nil) qs body
+
+    -- an alt branch in a `case` statement
+    -- for the Nil/Cons case, we're not inside a `case`.
     doAlt : String → CAlt → String
-    doAlt nm (CConAlt tag cname _ args body) = "((\{show tag}) \{conAlt env nm Lin args body})"
+    doAlt nm (CConAlt tag cname _ args qs body) = "((\{show tag}) \{conAlt env nm Lin args body})"
     doAlt nm (CDefAlt body) = "(else \{cexpToScm env body})"
     doAlt nm (CLitAlt lit body) = "((\{scmLit lit}) \{cexpToScm env body})"
 
+    -- doCase decides the top level path - case/cond/if/...
     doCase : String → List CAlt → String
-    -- I'm not sure the case tree should be generating this, c.f. deleteT23
+    -- I'm not sure the case tree should be generating this, c.f. deleteT23 (probably from doNumCon)
     doCase nm (CDefAlt body :: Nil) = cexpToScm env body
-    doCase nm (CConAlt tag cname _ args body :: Nil) = conAlt env nm Lin args body
+    -- TODO singleton ConsCon for pair, too. (Need to detect)
+    -- oh, but what if it's default?
+    doCase nm (cons@(CConAlt tag cname ConsCon args qs body ) :: rest) =
+      let consBranch = consAlt env nm qs body in
+      case rest of
+        Nil => consBranch
+        (CDefAlt body :: Nil) => "(if (null? \{nm}) \{cexpToScm env body} \{consBranch})"
+        (CConAlt _ _ NilCon _ qs body :: _) => "(if (null? \{nm}) \{nilAlt env qs body} \{consBranch})"
+        (CConAlt _ _ info _ _ _ :: _) => fatalError "\{show info} alt after cons"
+        (CLitAlt _ _ :: _) => fatalError "lit alt after cons"
+        _ => fatalError "too many alts after cons"
+    doCase nm (cons@(CConAlt tag cname NilCon args qs body ) :: rest) =
+      let nilBranch = consAlt env nm qs body in
+      case rest of
+        Nil => nilBranch
+        (CDefAlt body :: Nil) => "(if (null? \{nm}) \{nilBranch} \{cexpToScm env body})"
+        (CConAlt _ _ ConsCon _ qs body :: _) => "(if (null? \{nm}) \{nilBranch} \{consAlt env nm qs body})"
+        (CConAlt _ _ info _ _ _ :: _) => fatalError "\{show info} alt after nil"
+        (CLitAlt _ _ :: _) => fatalError "lit alt after nil"
+        _ => fatalError "too many alts after cons"
+    doCase nm (CConAlt tag cname _ args qs body :: Nil) = conAlt env nm Lin args body
     doCase nm alts@(CLitAlt _ _ :: _) = "(case \{nm} \{joinBy " " $ map (doAlt nm) alts})"
+    --
     doCase nm alts = "(case (vector-ref \{cexpToScm env sc} 0) \{joinBy " " $ map (doAlt nm) alts})"
 
 cexpToScm env (CRef nm) = scmName nm
@@ -141,12 +186,16 @@ cexpToScm env (CLetRec nm t u) =
 cexpToScm env (CLetLoop _ _) = fatalError "CLetLoop in scheme codegen"
 cexpToScm env (CLoop _ _) = fatalError "CLoop in scheme codegen"
 cexpToScm env CErased = "#f"
-cexpToScm env (CConstr tag nm args quants) =
+cexpToScm env (CConstr tag nm args quants NilCon) = "'()"
-  -- FIXME need to deal with quants
+cexpToScm env (CConstr tag nm args quants ConsCon) = case argsToScm env args quants of
+  (a :: b :: Nil) => "(cons \{a} \{b})"
+  _ => fatalError "Wrong number of args on a ConsCon"
+cexpToScm env (CConstr tag nm args quants info) =
+  -- FIXME need to deal with quants (on both sides!)
   let args' = map (cexpToScm env) args in
   "(vector \{show tag} \{joinBy " " args'})"
 -- TODO
-cexpToScm env (CRaw _ _) = "CRaw"
+cexpToScm env (CRaw _ _) = fatalError "Stray CRaw"
 -- TODO We still have a couple of these in CompileExp, for the magic Nat
 cexpToScm env (CPrimOp op a b) = "(\{op} \{cexpToScm env a} \{cexpToScm env b})"
 
@@ -218,13 +267,13 @@ TODO this could be made faster by keeping a map of the done information
 REVIEW could I avoid most of this by using `function` instead of arrow functions?
 
 -/
-
+-- TODO factor out to CompilerCommon
 sortedNames : SortedMap QName CExp → List QName → List QName
 sortedNames defs names =
   map snd $ filter (not ∘ fst) $ foldl (go Nil) Nil $ map (True,) names
   where
     getBody : CAlt → CExp
-    getBody (CConAlt _ _ _ _ t) = t
+    getBody (CConAlt _ _ _ _ _ t) = t
     getBody (CLitAlt _ t) = t
     getBody (CDefAlt t) = t
 
@@ -251,7 +300,7 @@ sortedNames defs names =
     getNames deep acc (CRef qn) = (deep, qn) :: acc
     getNames deep acc (CLet _ t u) = getNames deep (getNames deep acc t) u
     getNames deep acc (CLetRec _ t u) = getNames deep (getNames deep acc t) u
-    getNames deep acc (CConstr _ _ ts _) = foldl (getNames deep) acc ts
+    getNames deep acc (CConstr _ _ ts _ info) = foldl (getNames deep) acc ts
     -- if the CRaw is called, then the deps are called
     getNames deep acc (CRaw _ deps) = acc -- map (_,_ deep) deps ++ acc
     -- wrote these out so I get an error when I add a new constructor

src/Lib/LiftLambda.newt

@@ -38,8 +38,8 @@ liftLambdaTm name env tm@(CCase t alts) = do
     liftLambdaAlt : CAlt → State ExpMap CAlt
     liftLambdaAlt (CDefAlt tm) = CDefAlt <$> liftLambdaTm name env tm
     liftLambdaAlt (CLitAlt l tm) = CLitAlt l <$> liftLambdaTm name env tm
-    liftLambdaAlt (CConAlt ix nm info args tm) =
+    liftLambdaAlt (CConAlt ix nm info args qs tm) =
-      CConAlt ix nm info args <$> liftLambdaTm name (env <>< map (_,_ Many) args) tm
+      CConAlt ix nm info args qs <$> liftLambdaTm name (env <>< map (_,_ Many) args) tm
 liftLambdaTm name@(QN ns nm) env tm@(CLam nm t) = do
   let (nms, t) = splitLam tm Lin
   t' <- liftLambdaTm name (env <>< nms) t

src/Lib/ProcessDecl.newt

@@ -408,6 +408,7 @@ processShortData ns fc lhs sigs = do
     mkDecl args acc tm = error (getFC tm) "Expected contructor application, got: \{show tm}"
 
 -- Identify Nat-like, enum-like, etc
+-- TODO handle erased fields
 populateConInfo : List TopEntry → List TopEntry
 populateConInfo entries =
   let (Nothing) = traverse checkEnum entries
@@ -415,10 +416,20 @@ populateConInfo entries =
     | Just (a :: b :: Nil) => (setInfo a FalseCon :: setInfo b TrueCon :: Nil)
     | Just entries => entries in
   let (a :: b :: Nil) = entries | _ => entries in
-  let (Just succ) = find isSucc entries | _ => entries in
+  fromMaybe entries $ checkNat entries <|> checkCons entries
-  let (Just zero) = find isZero entries | _ => entries in
+  -- let (Nothing) = checkNat entries | Just entries => entries in
-  setInfo zero ZeroCon :: setInfo succ SuccCon :: Nil
+  -- let (Nothing) = checkNat entries | Just entries => entries in
+  -- entries
   where
+    countFields : TopEntry → Int
+    countFields (MkEntry fc name type def eflags) = go type
+     where
+       go : Tm → Int
+       go (Pi fc nm _ Zero a b) = go b
+       go (Pi fc nm _ Many a b) = 1 + go b
+       go _ = 0
+    countFields _ = 0
+
     setInfo : TopEntry → ConInfo → TopEntry
     setInfo (MkEntry fc nm dty (DCon ix _ arity hn) flags) info = MkEntry fc nm dty (DCon ix info arity hn) flags
     setInfo x _ = x
@@ -431,11 +442,26 @@ populateConInfo entries =
     isZero (MkEntry fc nm dty (DCon _ _ Nil hn) flags) = True
     isZero _ = False
 
-    -- TODO - handle indexes, etc
+    -- TODO - handle indexes, erased fields, etc
     isSucc : TopEntry → Bool
     isSucc (MkEntry fc nm dty@(Pi _ _ _ _ (Ref _ a) (Ref _ b)) (DCon _ _ (Many :: Nil) hn) _) = a == b
     isSucc _ = False
 
+    -- assumes we've filtered down to two entries
+    checkNat : List TopEntry → Maybe (List TopEntry)
+    checkNat entries = do
+      succ <- find isSucc entries
+      zero <- find isZero entries
+      pure $ setInfo zero ZeroCon :: setInfo succ SuccCon :: Nil
+
+
+    -- assumes we've filtered down to two entries
+    checkCons : List TopEntry → Maybe (List TopEntry)
+    checkCons entries = do
+      nil <- find (\ x => countFields x == 0) entries
+      cons <- find (\x => countFields x == 2) entries
+      pure $ setInfo nil NilCon :: setInfo cons ConsCon :: Nil
+
 processData : String → FC → FC × String → Raw → List Decl → M Unit
 processData ns fc (nameFC, nm) ty cons = do
   log 1 $ \ _ => "-----"

src/Lib/ProcessModule.newt

@@ -174,7 +174,7 @@ invalidateModule modname = do
   let modules = join $ map getDeps $ toList top.modules
   let revMap = map swap modules
   let deps = foldl accumulate emptyMap revMap
-  go deps $ modname :: Nil
+  modifyTop [ modules $= go deps (modname :: Nil) ]
   where
     accumulate : SortedMap String (List String) → String × String → SortedMap String (List String)
     accumulate deps (k,v) = let prev = fromMaybe Nil $ lookupMap' k deps
@@ -183,9 +183,8 @@ invalidateModule modname = do
     getDeps : String × ModContext → List (String × String)
     getDeps (nm, mod) = map (nm , ) mod.modDeps
 
-    go : SortedMap String (List String) → List String → M Unit
+    go : SortedMap String (List String) → List String → SortedMap String ModContext → SortedMap String ModContext
-    go deps Nil = pure MkUnit
+    go deps Nil mods = mods
-    go deps (name :: names) = do
+    go deps (name :: names) mods =
-      modifyTop [modules $= deleteMap name]
+      let ds = fromMaybe Nil $ lookupMap' name deps in
-      let ds = fromMaybe Nil $ lookupMap' name deps
+      go deps (ds ++ names) (deleteMap name mods)
-      go deps $ ds ++ names

src/Lib/TCO.newt

@@ -26,12 +26,12 @@ tailNames (CLetLoop _ _) = Nil
 tailNames (CCase _ alts) = join $ map altTailNames alts
   where
     altTailNames : CAlt → List QName
-    altTailNames (CConAlt _ _ _ _ exp) = tailNames exp
+    altTailNames (CConAlt _ _ _ _ _ exp) = tailNames exp
     altTailNames (CDefAlt exp) = tailNames exp
     altTailNames (CLitAlt _ exp) = tailNames exp
 tailNames (CLet _ _ t) = tailNames t
 tailNames (CLetRec _ _ t) = tailNames t
-tailNames (CConstr _ _ args _) = Nil
+tailNames (CConstr _ _ args _ _) = Nil
 tailNames (CBnd _) = Nil
 tailNames (CFun _ tm) = tailNames tm
 tailNames (CLam _ _) = Nil
@@ -50,20 +50,20 @@ rewriteTailCalls nms tm = case tm of
   CAppRef nm args qs =>
       if length' args == length' qs
       then case getTag (S Z) nm nms of
-        Just ix => CConstr ix (show nm) args $ map (const Many) args
+        Just ix => CConstr ix (show nm) args (map (const Many) args) NormalCon
-        Nothing => CConstr Z "return" (tm :: Nil) (Many :: Nil)
+        Nothing => CConstr Z "return" (tm :: Nil) (Many :: Nil) NormalCon
-      else CConstr Z "return" (tm :: Nil) (Many :: Nil)
+      else CConstr Z "return" (tm :: Nil) (Many :: Nil) NormalCon
   CLetRec nm t u => CLetRec nm t $ rewriteTailCalls nms u
   CLet nm t u => CLet nm t $ rewriteTailCalls nms u
   CCase sc alts => CCase sc $ map rewriteAlt alts
-  tm => CConstr Z "return" (tm :: Nil) (Many :: Nil)
+  tm => CConstr Z "return" (tm :: Nil) (Many :: Nil) NormalCon
   where
       getTag : Nat → QName → List QName → Maybe Nat
       getTag t nm Nil = Nothing
       getTag t nm (n :: ns) = if n == nm then Just t else getTag (S t) nm ns
 
       rewriteAlt : CAlt -> CAlt
-      rewriteAlt (CConAlt ix nm info args t) = CConAlt ix nm info args $ rewriteTailCalls nms t
+      rewriteAlt (CConAlt ix nm info args qs t) = CConAlt ix nm info args qs $ rewriteTailCalls nms t
       rewriteAlt (CDefAlt t) = CDefAlt $ rewriteTailCalls nms t
       rewriteAlt (CLitAlt lit t) = CLitAlt lit $ rewriteTailCalls nms t
 
@@ -81,7 +81,7 @@ rewriteLoop qn tm = case tm of
     tm => tm
   where
     rewriteAlt : CAlt → CAlt
-    rewriteAlt (CConAlt ix nm info args t) = CConAlt ix nm info args $ rewriteLoop qn t
+    rewriteAlt (CConAlt ix nm info args qs t) = CConAlt ix nm info args qs $ rewriteLoop qn t
     rewriteAlt (CDefAlt t) = CDefAlt $ rewriteLoop qn t
     rewriteAlt (CLitAlt lit t) = CLitAlt lit $ rewriteLoop qn t
 
@@ -109,7 +109,7 @@ doOptimize fns = do
       let arglen = length' args
       let conargs = map (\k => CBnd (arglen - k - 1)) (range 0 arglen)
       let conquant = map (const Many) conargs
-      let arg = CConstr (S ix) (show qn) conargs conquant
+      let arg = CConstr (S ix) (show qn) conargs conquant NormalCon
       let body = CAppRef bouncer (CRef recName :: arg :: Nil) (Many :: Many :: Nil)
       pure (qn, CFun args body)
     mkWrap _ (qn, _) = error emptyFC "error in mkWrap: \{show qn} not a CFun"
@@ -119,7 +119,7 @@ doOptimize fns = do
     mkRecName (QN ns nm :: _) = pure $ QN ns "REC_\{nm}"
 
     mkAlt : List QName → (Nat × QName × List (Quant × Name) × CExp) -> CAlt
-    mkAlt nms (ix, qn, args, tm) = CConAlt (S ix) (show qn) NormalCon (map snd args) (rewriteTailCalls nms tm)
+    mkAlt nms (ix, qn, args, tm) = CConAlt (S ix) (show qn) NormalCon (map snd args) (map fst args) (rewriteTailCalls nms tm)
 
     splitFun : (QName × CExp) → M (QName × List (Quant × Name) × CExp)
     splitFun (qn, CFun args body) = pure (qn, args, body)

src/Lib/Types.newt

@@ -269,12 +269,14 @@ record MetaContext where
 
 derive Eq MetaMode
 
-data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon | TrueCon | FalseCon
+data ConInfo = NormalCon | SuccCon | ZeroCon | EnumCon | TrueCon | FalseCon | NilCon | ConsCon
 
 derive Eq ConInfo
 
 instance Show ConInfo where
   show NormalCon = ""
+  show ConsCon = "[C]"
+  show NilCon = "[N]"
   show FalseCon = "[F]"
   show TrueCon = "[T]"
   show SuccCon = "[S]"