Skip to content

[ refactor ] ScopedSnocList: Swap Scope on SnocList (Phase 2) #3513

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 3 commits into
base: main
Choose a base branch
from
Open

[ refactor ] ScopedSnocList: Swap Scope on SnocList (Phase 2) #3513

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
b26579d
[ refactor ] ScopedSnocList: Swap Scope on SnocList (Phase 2)
GulinSS Jun 2, 2025
d9c69f6
[ refactor ] Refactor and optimize `CaseBuilder` (#16)
GulinSS Mar 24, 2025
749fa54
[ fix ] CI
GulinSS Jun 3, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions idris2api.ipkg
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -196,6 +196,7 @@ modules =
Libraries.Data.SnocList.HasLength,
Libraries.Data.SnocList.LengthMatch,
Libraries.Data.SnocList.SizeOf,
Libraries.Data.SnocList.Quantifiers.Extra,
Libraries.Data.Span,
Libraries.Data.SortedMap,
Libraries.Data.SortedSet,
Expand Down
56 changes: 28 additions & 28 deletions src/Compiler/ANF.idr
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ import Core.Core
import Core.TT

import Data.List
import Data.List.Quantifiers
import Data.SnocList.Quantifiers
import Data.SnocList
import Data.Vect
import Libraries.Data.SortedSet
Expand Down Expand Up @@ -142,6 +142,12 @@ Show ANFDef where
AVars : Scope -> Type
AVars = All (\_ => Int)

namespace AVars
public export
empty : AVars Scope.empty
empty = [<]


data Next : Type where

nextVar : {auto v : Ref Next Int} ->
Expand All @@ -152,8 +158,8 @@ nextVar
pure i

lookup : {idx : _} -> (0 p : IsVar x idx vs) -> AVars vs -> Int
lookup First (x :: xs) = x
lookup (Later p) (x :: xs) = lookup p xs
lookup First (xs :< x) = x
lookup (Later p) (xs :< x) = lookup p xs

bindArgs : {auto v : Ref Next Int} ->
List ANF -> Core (List (AVar, Maybe ANF))
Expand Down Expand Up @@ -189,6 +195,15 @@ mlet fc val sc
= do i <- nextVar
pure $ ALet fc i val (sc (ALocal i))

bindAsFresh :
{auto v : Ref Next Int} ->
(args : List Name) -> AVars vars' ->
Core (List Int, AVars (Scope.ext vars' args))
bindAsFresh [] vs = pure ([], vs)
bindAsFresh (n :: ns) vs
= do i <- nextVar
mapFst (i ::) <$> bindAsFresh ns (vs :< i)

mutual
anfArgs : {vars : _} ->
{auto v : Ref Next Int} ->
Expand All @@ -213,7 +228,7 @@ mutual
_ => ACrash fc "Can't happen (AApp)"
anf vs (LLet fc x val sc)
= do i <- nextVar
let vs' = i :: vs
let vs' = vs :< i
pure $ ALet fc i !(anf vs val) !(anf vs' sc)
anf vs (LCon fc n ci t args)
= anfArgs fc vs args (ACon fc n ci t)
Expand Down Expand Up @@ -243,16 +258,8 @@ mutual
{auto v : Ref Next Int} ->
AVars vars -> LiftedConAlt vars -> Core AConAlt
anfConAlt vs (MkLConAlt n ci t args sc)
= do (is, vs') <- bindArgs args vs
= do (is, vs') <- bindAsFresh args vs
pure $ MkAConAlt n ci t is !(anf vs' sc)
where
bindArgs : (args : List Name) -> AVars vars' ->
Core (List Int, AVars (args ++ vars'))
bindArgs [] vs = pure ([], vs)
bindArgs (n :: ns) vs
= do i <- nextVar
(is, vs') <- bindArgs ns vs
pure (i :: is, i :: vs')

anfConstAlt : {vars : _} ->
{auto v : Ref Next Int} ->
Expand All @@ -264,25 +271,18 @@ export
toANF : LiftedDef -> Core ANFDef
toANF (MkLFun args scope sc)
= do v <- newRef Next (the Int 0)
(iargs, vsNil) <- bindArgs args []
let vs : AVars args = rewrite sym (appendNilRightNeutral args) in
vsNil
(iargs', vs) <- bindArgs scope vs
pure $ MkAFun (iargs ++ reverse iargs') !(anf vs sc)
where
bindArgs : {auto v : Ref Next Int} ->
(args : List Name) -> AVars vars' ->
Core (List Int, AVars (args ++ vars'))
bindArgs [] vs = pure ([], vs)
bindArgs (n :: ns) vs
= do i <- nextVar
(is, vs') <- bindArgs ns vs
pure (i :: is, i :: vs')
(iargs, vsNil) <- bindAsFresh (cast args) AVars.empty
let vs : AVars args
:= rewrite sym $ appendLinLeftNeutral args in
rewrite snocAppendAsFish Scope.empty args in vsNil
(iargs', vs) <- bindAsFresh (cast scope) vs
sc' <- anf (rewrite snocAppendAsFish args scope in vs) sc
pure $ MkAFun (iargs ++ iargs') sc'
toANF (MkLCon t a ns) = pure $ MkACon t a ns
toANF (MkLForeign ccs fargs t) = pure $ MkAForeign ccs fargs t
toANF (MkLError err)
= do v <- newRef Next (the Int 0)
pure $ MkAError !(anf [] err)
pure $ MkAError !(anf AVars.empty err)

export
freeVariables : ANF -> SortedSet AVar
Expand Down
52 changes: 26 additions & 26 deletions src/Compiler/CaseOpts.idr
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -37,38 +37,38 @@ case t of

shiftUnder : {args : _} ->
{idx : _} ->
(0 p : IsVar n idx (x :: args ++ vars)) ->
NVar n (args ++ x :: vars)
(0 p : IsVar n idx (Scope.addInner vars (Scope.bind args x))) ->
NVar n (Scope.addInner (Scope.bind vars x) args)
shiftUnder First = weakenNVar (mkSizeOf args) (MkNVar First)
shiftUnder (Later p) = insertNVar (mkSizeOf args) (MkNVar p)

shiftVar : {outer : Scope} -> {args : List Name} ->
NVar n (outer ++ (x :: args ++ vars)) ->
NVar n (outer ++ (args ++ x :: vars))
NVar n ((vars <>< args :< x) ++ outer) ->
NVar n ((vars :< x <>< args) ++ outer)
shiftVar nvar
= let out = mkSizeOf outer in
case locateNVar out nvar of
Left nvar => embed nvar
Right (MkNVar p) => weakenNs out (shiftUnder p)
Right (MkNVar p) => weakenNs out (shiftUndersN (mkSizeOf _) p)

mutual
shiftBinder : {outer, args : _} ->
(new : Name) ->
CExp (outer ++ old :: (args ++ vars)) ->
CExp (outer ++ (args ++ new :: vars))
CExp (((vars <>< args) :< old) ++ outer) ->
CExp ((vars :< new <>< args) ++ outer)
shiftBinder new (CLocal fc p)
= case shiftVar (MkNVar p) of
MkNVar p' => CLocal fc (renameVar p')
where
renameVar : IsVar x i (outer ++ (args ++ (old :: rest))) ->
IsVar x i (outer ++ (args ++ (new :: rest)))
renameVar : IsVar x i ((vars :< old <>< args) ++ local) ->
IsVar x i ((vars :< new <>< args) ++ local)
renameVar = believe_me -- it's the same index, so just the identity at run time
shiftBinder new (CRef fc n) = CRef fc n
shiftBinder {outer} new (CLam fc n sc)
= CLam fc n $ shiftBinder {outer = n :: outer} new sc
= CLam fc n $ shiftBinder {outer = outer :< n} new sc
shiftBinder new (CLet fc n inlineOK val sc)
= CLet fc n inlineOK (shiftBinder new val)
$ shiftBinder {outer = n :: outer} new sc
$ shiftBinder {outer = outer :< n} new sc
shiftBinder new (CApp fc f args)
= CApp fc (shiftBinder new f) $ map (shiftBinder new) args
shiftBinder new (CCon fc ci c tag args)
Expand All @@ -92,34 +92,34 @@ mutual

shiftBinderConAlt : {outer, args : _} ->
(new : Name) ->
CConAlt (outer ++ (x :: args ++ vars)) ->
CConAlt (outer ++ (args ++ new :: vars))
CConAlt (((vars <>< args) :< old) ++ outer) ->
CConAlt ((vars :< new <>< args) ++ outer)
shiftBinderConAlt new (MkConAlt n ci t args' sc)
= let sc' : CExp ((args' ++ outer) ++ (x :: args ++ vars))
= rewrite sym (appendAssociative args' outer (x :: args ++ vars)) in sc in
= let sc' : CExp (((vars <>< args) :< old) ++ (outer <>< args'))
= rewrite sym $ snocAppendFishAssociative (vars <>< args :< old) outer args' in sc in
MkConAlt n ci t args' $
rewrite (appendAssociative args' outer (args ++ new :: vars))
in shiftBinder new {outer = args' ++ outer} sc'
rewrite snocAppendFishAssociative (vars :< new <>< args) outer args'
in shiftBinder new {outer = outer <>< args'} sc'

shiftBinderConstAlt : {outer, args : _} ->
(new : Name) ->
CConstAlt (outer ++ (x :: args ++ vars)) ->
CConstAlt (outer ++ (args ++ new :: vars))
CConstAlt (((vars <>< args) :< old) ++ outer) ->
CConstAlt ((vars :< new <>< args) ++ outer)
shiftBinderConstAlt new (MkConstAlt c sc) = MkConstAlt c $ shiftBinder new sc

-- If there's a lambda inside a case, move the variable so that it's bound
-- outside the case block so that we can bind it just once outside the block
liftOutLambda : {args : _} ->
(new : Name) ->
CExp (old :: args ++ vars) ->
CExp (args ++ new :: vars)
CExp (Scope.bind (Scope.ext vars args) old) ->
CExp (Scope.ext (Scope.bind vars new) args)
liftOutLambda = shiftBinder {outer = Scope.empty}

-- If all the alternatives start with a lambda, we can have a single lambda
-- binding outside
tryLiftOut : (new : Name) ->
List (CConAlt vars) ->
Maybe (List (CConAlt (new :: vars)))
Maybe (List (CConAlt (Scope.bind vars new)))
tryLiftOut new [] = Just []
tryLiftOut new (MkConAlt n ci t args (CLam fc x sc) :: as)
= do as' <- tryLiftOut new as
Expand All @@ -129,7 +129,7 @@ tryLiftOut _ _ = Nothing

tryLiftOutConst : (new : Name) ->
List (CConstAlt vars) ->
Maybe (List (CConstAlt (new :: vars)))
Maybe (List (CConstAlt (Scope.bind vars new)))
tryLiftOutConst new [] = Just []
tryLiftOutConst new (MkConstAlt c (CLam fc x sc) :: as)
= do as' <- tryLiftOutConst new as
Expand All @@ -139,7 +139,7 @@ tryLiftOutConst _ _ = Nothing

tryLiftDef : (new : Name) ->
Maybe (CExp vars) ->
Maybe (Maybe (CExp (new :: vars)))
Maybe (Maybe (CExp (Scope.bind vars new)))
tryLiftDef new Nothing = Just Nothing
tryLiftDef new (Just (CLam fc x sc))
= let sc' = liftOutLambda {args = []} new sc in
Expand Down Expand Up @@ -318,8 +318,8 @@ doCaseOfCase fc x xalts xdef alts def
updateAlt (MkConAlt n ci t args sc)
= MkConAlt n ci t args $
CConCase fc sc
(map (weakenNs (mkSizeOf args)) alts)
(map (weakenNs (mkSizeOf args)) def)
(map (weakensN (mkSizeOf args)) alts)
(map (weakensN (mkSizeOf args)) def)

updateDef : CExp vars -> CExp vars
updateDef sc = CConCase fc sc alts def
Expand Down
Loading
Loading