2 | module Compiler.ES.ToAst

  4 | import Data.Vect

  5 | import Core.CompileExpr

  6 | import Core.Context

  7 | import Compiler.ES.Ast

  8 | import Compiler.ES.State

 15 | tag : Name -> Maybe Int -> Tag

 16 | tag n Nothing = TypeCon n

 17 | tag n (Just i) = DataCon i n

 20 | assign : (e : Effect) -> Exp -> Stmt (Just e)

 21 | assign Returns          = Return

 22 | assign (ErrorWithout v) = Assign v

 25 |   getInteger : NamedCExp -> Maybe Integer

 26 |   getInteger (NmPrimVal _ $ BI x) = Just x

 27 |   getInteger x                    = integerArith x

 29 |   -- this is a local hack to fix #1320 for the JS backend

 30 |   -- the moste basic sequences of arithmetic `Integer` expressions

 31 |   -- are evaluated to prevent us from introducing slow

 32 |   -- cascades of (1n + ...) coming from small `Nat` literals.

 33 |   integerArith : NamedCExp -> Maybe Integer

 34 |   integerArith (NmOp _ (Add IntegerType) [x,y]) =

 35 |     [| getInteger x + getInteger y |]

 36 |   integerArith (NmOp _ (Mul IntegerType) [x,y]) =

 37 |     [| getInteger x * getInteger y |]

 38 |   integerArith _ = Nothing

 41 |   -- Converts a `NamedCExp` by calling `stmt` with a

 42 |   -- newly generated local variable.

 43 |   -- If the result is a single assignment statement

 44 |   -- and the given filter function returns a `Just a`,

 45 |   -- only result `a` is returned.

 46 |   -- If the result is more complex or the filter returns

 47 |   -- `Nothing`, the resulting block

 48 |   -- will be kept and a pointer to the new variable

 49 |   -- will be returned which can then be used for instance

 50 |   -- as a function's argument.

 51 |   lift :  { auto c : Ref ESs ESSt }

 52 |        -> NamedCExp

 53 |        -> (filter  : Exp -> Maybe a)

 54 |        -> (fromVar : Var -> a)

 55 |        -> Core (List (Stmt Nothing), a)

 56 |   lift n filter fromVar = do

 57 |     l <- nextLocal

 58 |     b <- stmt (ErrorWithout l) n

 59 |     let pair = ([declare b], fromVar l)

 60 |     case b of

 61 |       -- elaborator needed some help here

 62 |       Assign _ e => pure $ maybe pair (the (List _) [],) (filter e)

 63 |       _          => pure pair

 65 |   -- Convert and lift (if necessary, see comment for `lift`)

 66 |   -- a function argument. The filter function used to

 67 |   -- decide whether to keep or lift a function argument

 68 |   -- comes from the passed `ESSt` state and can therefore

 69 |   -- vary across backends.

 70 |   liftArg : { auto c : Ref ESs ESSt }

 71 |            -> NamedCExp

 72 |            -> Core (List (Stmt Nothing), Exp)

 73 |   liftArg x = do

 74 |     f <- isArg <$> get ESs

 75 |     lift x (\e => guard (f e) $> e) (EMinimal . MVar)

 77 |   -- Convert and lift (if necessary, see comment for `lift`)

 78 |   -- a function expression.

 79 |   liftFun : { auto c : Ref ESs ESSt }

 80 |            -> NamedCExp

 81 |            -> Core (List (Stmt Nothing), Exp)

 82 |   liftFun x = do

 83 |     f <- isFun <$> get ESs

 84 |     lift x (\e => guard (f e) $> e) (EMinimal . MVar)

 86 |   -- Convert and lift (if necessary, see comment for `liftArg`)

 87 |   -- a `Vect` of function arguments.

 88 |   liftArgsVect : { auto c : Ref ESs ESSt }

 89 |                -> Vect n NamedCExp

 90 |                -> Core (List (Stmt Nothing), Vect n Exp)

 91 |   liftArgsVect xs = do

 92 |     ps <- traverseVect liftArg xs

 93 |     pure (concatMap fst ps, map snd ps)

 95 |   -- Convert and lift (if necessary, see comment for `liftArg`)

 96 |   -- a `List` of function arguments.

 97 |   liftArgs : { auto c : Ref ESs ESSt }

 98 |            -> List NamedCExp

 99 |            -> Core (List (Stmt Nothing), List Exp)

100 |   liftArgs xs = do

101 |     ps <- traverse liftArg xs

102 |     pure (concatMap fst ps, map snd ps)

104 |   -- Convert and lift an expression. If the result is

105 |   -- not a `Minimal` expression, an additional assignment statement is

106 |   -- generated. This is used to lift the scrutinees of

107 |   -- constructor case expressions to make sure they are

108 |   -- only evluated once (see also PR #1494).

109 |   liftMinimal : { auto c : Ref ESs ESSt }

110 |               -> NamedCExp

111 |               -> Core (List (Stmt Nothing), Minimal)

112 |   liftMinimal n = lift n toMinimal MVar

114 |   -- creates a (possibly multiargument) lambda.

115 |   lambda : {auto c : Ref ESs ESSt} -> Name -> NamedCExp -> Core Exp

116 |   lambda n x = go [n] x

117 |     where go : List Name -> NamedCExp -> Core Exp

118 |           go ns (NmLam _ n x) = go (n :: ns) x

119 |           go ns x             = do

120 |             vs <- traverse registerLocal (reverse ns)

121 |             ELam vs <$> stmt Returns x

123 |   -- convert a `NamedCExp` to a sequence of statements.

124 |   export

125 |   stmt :  {auto c : Ref ESs ESSt}

126 |         -> (e : Effect)

127 |         -> NamedCExp

128 |         -> Core (Stmt $ Just e)

129 |   -- a local name gets registered or resolved

130 |   stmt e (NmLocal _ n) = assign e . EMinimal <$> getOrRegisterLocal n

132 |   -- a function name gets registered or resolved

133 |   stmt e (NmRef _ n) = assign e . EMinimal . MVar <$> getOrRegisterRef n

135 |   stmt e (NmLam _ n x) = assign e <$> lambda n x

137 |   -- in case of a let expression, we just generate two

138 |   -- blocks of statements and concatenate them.

139 |   -- We always introduce a new local variable for `n`,

140 |   -- since a variable called `n` might be used in both blocks.

141 |   stmt e (NmLet _ n y z) = do

142 |     v  <- nextLocal

143 |     b1 <- stmt (ErrorWithout v) y

144 |     addLocal n (MVar v)

145 |     b2 <- stmt e z

146 |     pure $ prepend [declare b1] b2

148 |   -- when applying a function, we potentially need to

149 |   -- lift both, the function expression itself and the argument

150 |   -- list, to the surrounding scope.

151 |   stmt e (NmApp _ x xs) = do

152 |     (mbx, vx)    <- liftFun x

153 |     (mbxs, args) <- liftArgs xs

154 |     pure . prepend (mbx ++ mbxs) $ assign e (EApp vx args)

156 |   stmt e (NmCon _ n ci tg xs) = do

157 |     (mbxs, args) <- liftArgs xs

158 |     pure . prepend mbxs $ assign e (ECon (tag n tg) ci args)

160 |   stmt e o@(NmOp _ x xs) =

161 |     case integerArith o of

162 |       Just n  => pure . assign e $ EPrimVal (BI n)

163 |       Nothing => do

164 |         (mbxs, args) <- liftArgsVect xs

165 |         pure . prepend mbxs $ assign e (EOp x args)

167 |   stmt e (NmExtPrim _ n xs) = do

168 |     (mbxs, args) <- liftArgs xs

169 |     pure . prepend mbxs $ assign e (EExtPrim n args)

171 |   stmt e (NmForce _ _ x) = do

172 |     (mbx, vx) <- liftFun x

173 |     pure . prepend mbx $ assign e (EApp vx [])

175 |   stmt e (NmDelay _ _ x) = assign e . ELam [] <$> stmt Returns x

177 |   -- No need for a `switch` if we only have a single branch.

178 |   -- It's still necessary to lift the scrutinee, however,

179 |   -- since its fields might be accessed several times in

180 |   -- the implementation of `x`.

181 |   stmt e (NmConCase _ sc [x] Nothing) = do

182 |     (mbx, vx) <- liftMinimal sc

183 |     b         <- body <$> conAlt e vx x

184 |     pure $ prepend mbx b

186 |   -- No need for a `switch` statement if we only have

187 |   -- a `default` branch.

188 |   stmt e (NmConCase _ _ [] (Just x)) = stmt e x

190 |   -- Create a `switch` statement from a pattern match

191 |   -- on constructors. The scrutinee is lifted to the

192 |   -- surrounding scope and memoized if necessary.

193 |   stmt e (NmConCase _ sc xs x) = do

194 |     (mbx, vx) <- liftMinimal sc

195 |     alts      <- traverse (conAlt e vx) xs

196 |     def       <- traverseOpt (stmt e) x

197 |     pure . prepend mbx $ ConSwitch e vx alts def

199 |   -- Pattern matches on constants behave very similar

200 |   -- to the ones on constructors.

201 |   stmt e (NmConstCase _ _ [x] Nothing) = body <$> constAlt e x

202 |   stmt e (NmConstCase _ _ [] (Just x)) = stmt e x

203 |   stmt e (NmConstCase _ sc xs x) = do

204 |     (mbx, ex) <- liftArg sc

205 |     alts      <- traverse (constAlt e) xs

206 |     def       <- traverseOpt (stmt e) x

207 |     pure . prepend mbx $ ConstSwitch e ex alts def

209 |   stmt e (NmPrimVal _ x) = pure . assign e $ EPrimVal x

211 |   stmt e (NmErased _)    = pure . assign e $ EErased

213 |   stmt _ (NmCrash _ x)   = pure $ Error x

215 |   -- a single branch in a pattern match on constructors

216 |   conAlt :  { auto c : Ref ESs ESSt }

217 |          -> (e         : Effect)

218 |          -> (scrutinee : Minimal)

219 |          -> NamedConAlt

220 |          -> Core (EConAlt e)

221 |   conAlt e sc (MkNConAlt n ci tg args x) = do

222 |     -- We map the list of args to the corresponding

223 |     -- data projections (field accessors). They'll

224 |     -- be then properly inlined when converting `x`.

225 |     projections sc args

226 |     MkEConAlt (tag n tg) ci <$> stmt e x

228 |   -- a single branch in a pattern match on a constant

229 |   constAlt :  { auto c : Ref ESs ESSt }

230 |            -> (e : Effect)

231 |            -> NamedConstAlt

232 |            -> Core (EConstAlt e)

233 |   constAlt e (MkNConstAlt c x) = MkEConstAlt c <$> stmt e x