dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Cons/Nil optimization for scheme backend

Browse Source
This commit is contained in:
Steve Dunham
2026-03-18 17:07:48 -07:00
parent 4ce5d470ba
commit 5eb43f6252
10 changed files with 151 additions and 74 deletions
Download Patch File Download Diff File Expand all files Collapse all files

21
prim.ss
View File

@@ -38,22 +38,9 @@
;; REVIEW returns #f for failure
(define Prelude.stringToInt string->number)
;; coerce scheme list to newt
(define (list->List xs)
(define (go acc xs)
(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.unpack str) (string->list str))
(define (Prelude.pack cs) (list->string cs))
(define (Prelude.fastConcat strings) (apply string-append 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))

3
src/LSP.newt
View File

@@ -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

45
src/Lib/CompileExp.newt
View File

@@ -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
_ => error fc "\{show nm} is not constructor"
DCon ix info qs _ => CConAlt ix nm info args qs <$> compileTerm tm
_ => 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 _ _ ZeroCon _ _) = True
numAltP (CConAlt _ _ SuccCon _ _ _) = 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 FalseCon args tm) = CLitAlt (LBool False) tm
enumAlt (CConAlt ix nm TrueCon args tm) = CLitAlt (LBool True) 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 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

14
src/Lib/CompileJS.newt
View File

@@ -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

67
src/Lib/CompileScheme.newt
View File

@@ -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) =
-- FIXME need to deal with quants
cexpToScm env (CConstr tag nm args quants NilCon) = "'()"
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

4
src/Lib/LiftLambda.newt
View File

@@ -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) =
CConAlt ix nm info args <$> liftLambdaTm name (env <>< map (_,_ Many) args) tm
liftLambdaAlt (CConAlt ix nm info args qs 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

34
src/Lib/ProcessDecl.newt
View File

@@ -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
let (Just zero) = find isZero entries | _ => entries in
setInfo zero ZeroCon :: setInfo succ SuccCon :: Nil
fromMaybe entries $ checkNat entries <|> checkCons entries
-- let (Nothing) = checkNat entries | Just entries => entries in
-- 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 $ \ _ => "-----"

13
src/Lib/ProcessModule.newt
View File

@@ -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 deps Nil = pure MkUnit
go deps (name :: names) = do
modifyTop [modules $= deleteMap name]
let ds = fromMaybe Nil $ lookupMap' name deps
go deps $ ds ++ names
go : SortedMap String (List String) → List String → SortedMap String ModContext → SortedMap String ModContext
go deps Nil mods = mods
go deps (name :: names) mods =
let ds = fromMaybe Nil $ lookupMap' name deps in
go deps (ds ++ names) (deleteMap name mods)

20
src/Lib/TCO.newt
View File

@@ -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
Nothing => CConstr Z "return" (tm :: Nil) (Many :: Nil)
else CConstr Z "return" (tm :: Nil) (Many :: Nil)
Just ix => CConstr ix (show nm) args (map (const Many) args) NormalCon
Nothing => CConstr Z "return" (tm :: Nil) (Many :: Nil) NormalCon
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)

4
src/Lib/Types.newt
View File

@@ -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]"