git.iko.soy/Idris-dev
on d280640 help sign in
Idris-dev/src/IRTS/Compiler.hs
652 lines 24 kB history raw
1{-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-}
3module IRTS.Compiler(compile, generate) where
5import IRTS.Lang
6import IRTS.LangOpts
7import IRTS.Defunctionalise
8import IRTS.Simplified
9import IRTS.CodegenCommon
10import IRTS.CodegenC
11import IRTS.DumpBC
12import IRTS.CodegenJavaScript
13import IRTS.Inliner
14import IRTS.Exports
16import Idris.AbsSyntax
17import Idris.AbsSyntaxTree
18import Idris.ASTUtils
19import Idris.Erasure
20import Idris.Error
21import Idris.Output
23import Debug.Trace
25import Idris.Core.TT
26import Idris.Core.Evaluate
27import Idris.Core.CaseTree
29import Control.Category
30import Prelude hiding (id, (.))
32import Control.Applicative
33import Control.Monad.State
34import Data.Maybe
35import Data.List
36import Data.Ord
37import Data.IntSet (IntSet)
38import qualified Data.IntSet as IS
39import qualified Data.Map as M
40import qualified Data.Set as S
41import System.Process
42import System.IO
43import System.Exit
44import System.Directory
45import System.Environment
46import System.FilePath ((</>), addTrailingPathSeparator)
48-- | Compile to simplified forms and return CodegenInfo
49compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo
50compile codegen f mtm
51 = do checkMVs -- check for undefined metavariables
52 checkTotality -- refuse to compile if there are totality problems
53 exports <- findExports
54 let rootNames = case mtm of
55 Nothing -> []
56 Just t -> freeNames t
58 reachableNames <- performUsageAnalysis
59 (rootNames ++ getExpNames exports)
60 maindef <- case mtm of
61 Nothing -> return []
62 Just tm -> do md <- irMain tm
63 logCodeGen 1 $ "MAIN: " ++ show md
64 return [(sMN 0 "runMain", md)]
65 objs <- getObjectFiles codegen
66 libs <- getLibs codegen
67 flags <- getFlags codegen
68 hdrs <- getHdrs codegen
69 impdirs <- allImportDirs
70 defsIn <- mkDecls reachableNames
71 -- if no 'main term' given, generate interface files
72 let iface = case mtm of
73 Nothing -> True
74 Just _ -> False
76 let defs = defsIn ++ maindef
78 -- Inlined top level LDecl made here
79 let defsInlined = inlineAll defs
80 let defsUniq = map (allocUnique (addAlist defsInlined emptyContext))
81 defsInlined
83 let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)
84 let ctxtIn = addAlist tagged emptyContext
86 logCodeGen 1 "Defunctionalising"
87 let defuns_in = defunctionalise nexttag ctxtIn
88 logCodeGen 5 $ show defuns_in
89 logCodeGen 1 "Inlining"
90 let defuns = inline defuns_in
91 logCodeGen 5 $ show defuns
92 logCodeGen 1 "Resolving variables for CG"
94 let checked = simplifyDefs defuns (toAlist defuns)
95 outty <- outputTy
96 dumpCases <- getDumpCases
97 dumpDefun <- getDumpDefun
98 case dumpCases of
99 Nothing -> return ()
100 Just f -> runIO $ writeFile f (showCaseTrees defs)
101 case dumpDefun of
102 Nothing -> return ()
103 Just f -> runIO $ writeFile f (dumpDefuns defuns)
104 triple <- Idris.AbsSyntax.targetTriple
105 cpu <- Idris.AbsSyntax.targetCPU
106 logCodeGen 1 "Building output"
107 case checked of
108 OK c -> do return $ CodegenInfo f outty triple cpu
109 hdrs impdirs objs libs flags
110 NONE c (toAlist defuns)
111 tagged iface exports
112 Error e -> ierror e
113 where checkMVs = do i <- getIState
114 case map fst (idris_metavars i) \\ primDefs of
115 [] -> return ()
116 ms -> do iputStrLn $ "WARNING: There are incomplete holes:\n " ++ show ms
117 iputStrLn "\nEvaluation of any of these will crash at run time."
118 return ()
119 checkTotality = do i <- getIState
120 case idris_totcheckfail i of
121 [] -> return ()
122 ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg
124generate :: Codegen -> FilePath -> CodegenInfo -> IO ()
125generate codegen mainmod ir
126 = case codegen of
127 -- Built-in code generators (FIXME: lift these out!)
128 Via "c" -> codegenC ir
129 -- Any external code generator
130 Via cg -> do let cmd = "idris-codegen-" ++ cg
131 args = [mainmod, "-o", outputFile ir] ++ compilerFlags ir
132 exit <- rawSystem cmd args
133 when (exit /= ExitSuccess) $
134 putStrLn ("FAILURE: " ++ show cmd ++ " " ++ show args)
135 Bytecode -> dumpBC (simpleDecls ir) (outputFile ir)
137irMain :: TT Name -> Idris LDecl
138irMain tm = do
139 i <- irTerm M.empty [] tm
140 return $ LFun [] (sMN 0 "runMain") [] (LForce i)
142mkDecls :: [Name] -> Idris [(Name, LDecl)]
143mkDecls used
144 = do i <- getIState
145 let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
146 decls <- mapM build ds
147 return decls
149showCaseTrees :: [(Name, LDecl)] -> String
150showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)
151 where
152 showCT (n, LFun _ f args lexp)
153 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"
154 ++ show lexp
155 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
157 defnRank :: (Name, LDecl) -> String
158 defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n
159 defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n
161 nameRank :: Name -> String
162 nameRank (UN s) = "1" ++ show s
163 nameRank (MN i s) = "2" ++ show s ++ show i
164 nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n
165 nameRank (SN sn) = "4" ++ snRank sn
166 nameRank n = "5" ++ show n
168 snRank :: SpecialName -> String
169 snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i
170 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args
171 snRank (ParentN n s) = "3" ++ nameRank n ++ show s
172 snRank (MethodN n) = "4" ++ nameRank n
173 snRank (CaseN _ n) = "5" ++ nameRank n
174 snRank (ElimN n) = "6" ++ nameRank n
175 snRank (InstanceCtorN n) = "7" ++ nameRank n
176 snRank (WithN i n) = "8" ++ nameRank n ++ show i
178isCon (TyDecl _ _) = True
179isCon _ = False
181build :: (Name, Def) -> Idris (Name, LDecl)
182build (n, d)
183 = do i <- getIState
184 case getPrim n i of
185 Just (ar, op) ->
186 let args = map (\x -> sMN x "op") [0..] in
187 return (n, (LFun [] n (take ar args)
188 (LOp op (map (LV . Glob) (take ar args)))))
189 _ -> do def <- mkLDecl n d
190 logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
191 return (n, def)
192 where getPrim n i
193 | Just (ar, op) <- lookup n (idris_scprims i)
194 = Just (ar, op)
195 | Just ar <- lookup n (S.toList (idris_externs i))
196 = Just (ar, LExternal n)
197 getPrim n i = Nothing
199declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x
200declArgs args inl n x = LFun (if inl then [Inline] else []) n args x
202mkLDecl n (Function tm _)
203 = declArgs [] True n <$> irTerm M.empty [] tm
205mkLDecl n (CaseOp ci _ _ _ pats cd)
206 = declArgs [] (case_inlinable ci || caseName n) n <$> irTree args sc
207 where
208 (args, sc) = cases_runtime cd
210 -- Always attempt to inline functions arising from 'case' expressions
211 caseName (SN (CaseN _ _)) = True
212 caseName (SN (WithN _ _)) = True
213 caseName (NS n _) = caseName n
214 caseName _ = False
216mkLDecl n (TyDecl (DCon tag arity _) _) =
217 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)
219mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
220mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run
222data VarInfo = VI
223 { viMethod :: Maybe Name
224 }
225 deriving Show
227type Vars = M.Map Name VarInfo
229irTerm :: Vars -> [Name] -> Term -> Idris LExp
230irTerm vs env tm@(App _ f a) = do
231 ist <- getIState
232 case unApply tm of
233 (P _ n _, args)
234 | n `elem` map fst (idris_metavars ist) \\ primDefs
235 -> return $ LError $ "ABORT: Attempt to evaluate hole " ++ show n
236 (P _ (UN m) _, args)
237 | m == txt "mkForeignPrim"
238 -> doForeign vs env (reverse (drop 4 args)) -- drop implicits
240 (P _ (UN u) _, [_, arg])
241 | u == txt "unsafePerformPrimIO"
242 -> irTerm vs env arg
244 -- TMP HACK - until we get inlining.
245 (P _ (UN r) _, [_, _, _, _, _, arg])
246 | r == txt "replace"
247 -> irTerm vs env arg
249 -- 'void' doesn't have any pattern clauses and only gets called on
250 -- erased things in higher order contexts (also a TMP HACK...)
251 (P _ (UN r) _, _)
252 | r == txt "void"
253 -> return LNothing
255 -- Laziness, the old way
256 (P _ (UN l) _, [_, arg])
257 | l == txt "lazy"
258 -> error "lazy has crept in somehow"
260 (P _ (UN l) _, [_, arg])
261 | l == txt "force"
262 -> LForce <$> irTerm vs env arg
264 -- Laziness, the new way
265 (P _ (UN l) _, [_, _, arg])
266 | l == txt "Delay"
267 -> LLazyExp <$> irTerm vs env arg
269 (P _ (UN l) _, [_, _, arg])
270 | l == txt "Force"
271 -> LForce <$> irTerm vs env arg
273 (P _ (UN a) _, [_, _, _, arg])
274 | a == txt "assert_smaller"
275 -> irTerm vs env arg
277 (P _ (UN a) _, [_, arg])
278 | a == txt "assert_total"
279 -> irTerm vs env arg
281 (P _ (UN p) _, [_, arg])
282 | p == txt "par"
283 -> do arg' <- irTerm vs env arg
284 return $ LOp LPar [LLazyExp arg']
286 (P _ (UN pf) _, [arg])
287 | pf == txt "prim_fork"
288 -> do arg' <- irTerm vs env arg
289 return $ LOp LFork [LLazyExp arg']
291 (P _ (UN m) _, [_,size,t])
292 | m == txt "malloc"
293 -> irTerm vs env t
295 (P _ (UN tm) _, [_,t])
296 | tm == txt "trace_malloc"
297 -> irTerm vs env t -- TODO
299 -- This case is here until we get more general inlining. It's just
300 -- a really common case, and the laziness hurts...
301 (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),
302 (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])
303 | be == txt "ifThenElse"
304 , d == txt "Delay"
305 , d' == txt "Delay"
306 , b == txt "Bool"
307 , p == txt "Prelude"
308 -> do
309 x' <- irTerm vs env x
310 t' <- irTerm vs env t
311 e' <- irTerm vs env e
312 return (LCase Shared x'
313 [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
314 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
315 ])
317 -- data constructor
318 (P (DCon t arity _) n _, args) -> do
319 detag <- fgetState (opt_detaggable . ist_optimisation n)
320 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
322 let isNewtype = length used == 1 && detag
323 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
325 -- The following code removes fields from data constructors
326 -- and performs the newtype optimisation.
327 --
328 -- The general rule here is:
329 -- Everything we get as input is not touched by erasure,
330 -- so it conforms to the official arities and types
331 -- and we can reason about it like it's plain TT.
332 --
333 -- It's only the data that leaves this point that's erased
334 -- and possibly no longer typed as the original TT version.
335 --
336 -- Especially, underapplied constructors must yield functions
337 -- even if all the remaining arguments are erased
338 -- (the resulting function *will* be applied, to NULLs).
339 --
340 -- This will probably need rethinking when we get erasure from functions.
342 -- "padLams" will wrap our term in LLam-bdas and give us
343 -- the "list of future unerased args" coming from these lambdas.
344 --
345 -- We can do whatever we like with the list of unerased args,
346 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
347 let padLams = padLambdas used (length args) arity
349 case compare (length args) arity of
351 -- overapplied
352 GT -> ifail ("overapplied data constructor: " ++ show tm ++
353 "\nDEBUG INFO:\n" ++
354 "Arity: " ++ show arity ++ "\n" ++
355 "Arguments: " ++ show args ++ "\n" ++
356 "Pruned arguments: " ++ show argsPruned)
358 -- exactly saturated
359 EQ | isNewtype
360 -> irTerm vs env (head argsPruned)
362 | otherwise -- not newtype, plain data ctor
363 -> buildApp (LV $ Glob n) argsPruned
365 -- not saturated, underapplied
366 LT | isNewtype -- newtype
367 , length argsPruned == 1 -- and we already have the value
368 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
369 <$> irTerm vs env (head argsPruned)
371 | isNewtype -- newtype but the value is not among args yet
372 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
374 -- not a newtype, just apply to a constructor
375 | otherwise
376 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
378 -- type constructor
379 (P (TCon t a) n _, args) -> return LNothing
381 -- an external name applied to arguments
382 (P _ n _, args) | S.member (n, length args) (idris_externs ist) -> do
383 LOp (LExternal n) <$> mapM (irTerm vs env) args
385 -- a name applied to arguments
386 (P _ n _, args) -> do
387 case lookup n (idris_scprims ist) of
388 -- if it's a primitive that is already saturated,
389 -- compile to the corresponding op here already to save work
390 Just (arity, op) | length args == arity
391 -> LOp op <$> mapM (irTerm vs env) args
393 -- otherwise, just apply the name
394 _ -> applyName n ist args
396 -- turn de bruijn vars into regular named references and try again
397 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
399 (f, args)
400 -> LApp False
401 <$> irTerm vs env f
402 <*> mapM (irTerm vs env) args
404 where
405 buildApp :: LExp -> [Term] -> Idris LExp
406 buildApp e [] = return e
407 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
409 applyToNames :: LExp -> [Name] -> LExp
410 applyToNames tm [] = tm
411 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
413 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
414 padLambdas used startIdx endSIdx mkTerm
415 = LLam allNames $ mkTerm nonerasedNames
416 where
417 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
418 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
420 applyName :: Name -> IState -> [Term] -> Idris LExp
421 applyName n ist args =
422 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
423 where
424 erase (i, x)
425 | i >= arity || i `elem` used = x
426 | otherwise = Erased
428 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
429 Just (CaseOp ci ty tys def tot cdefs) -> length tys
430 Just (TyDecl (DCon tag ar _) _) -> ar
431 Just (TyDecl Ref ty) -> length $ getArgTys ty
432 Just (Operator ty ar op) -> ar
433 Just def -> error $ "unknown arity: " ++ show (n, def)
434 Nothing -> 0 -- no definition, probably local name => can't erase anything
436 -- name for purposes of usage info lookup
437 uName
438 | Just n' <- viMethod =<< M.lookup n vs = n'
439 | otherwise = n
441 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
442 fst4 (x,_,_,_) = x
444irTerm vs env (P _ n _) = return $ LV (Glob n)
445irTerm vs env (V i)
446 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
447 | otherwise = ifail $ "bad de bruijn index: " ++ show i
449irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
450 where
451 n' = uniqueName n env
453irTerm vs env (Bind n (Let _ v) sc)
454 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
456irTerm vs env (Bind _ _ _) = return $ LNothing
458irTerm vs env (Proj t (-1)) = do
459 t' <- irTerm vs env t
460 return $ LOp (LMinus (ATInt ITBig))
461 [t', LConst (BI 1)]
463irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
464irTerm vs env (Constant TheWorld) = return $ LNothing
465irTerm vs env (Constant c) = return $ LConst c
466irTerm vs env (TType _) = return $ LNothing
467irTerm vs env Erased = return $ LNothing
468irTerm vs env Impossible = return $ LNothing
470doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
471doForeign vs env (ret : fname : world : args)
472 = do args' <- mapM splitArg args
473 let fname' = toFDesc fname
474 let ret' = toFDesc ret
475 return $ LForeign ret' fname' args'
476 where
477 splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
478 = do let l' = toFDesc l
479 r' <- irTerm vs env r
480 return (l', r')
481 splitArg _ = ifail $ "Badly formed foreign function call"
483 toFDesc (Constant (Str str)) = FStr str
484 toFDesc tm
485 | (P _ n _, []) <- unApply tm = FCon (deNS n)
486 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)
487 toFDesc _ = FUnknown
489 deNS (NS n _) = n
490 deNS n = n
491doForeign vs env xs = ifail "Badly formed foreign function call"
493irTree :: [Name] -> SC -> Idris LExp
494irTree args tree = do
495 logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
496 LLam args <$> irSC M.empty tree
498irSC :: Vars -> SC -> Idris LExp
499irSC vs (STerm t) = irTerm vs [] t
500irSC vs (UnmatchedCase str) = return $ LError str
502irSC vs (ProjCase tm alts) = do
503 tm' <- irTerm vs [] tm
504 alts' <- mapM (irAlt vs tm') alts
505 return $ LCase Shared tm' alts'
507-- Transform matching on Delay to applications of Force.
508irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])
509 | delay == txt "Delay"
510 = do sc' <- irSC vs $ mkForce n' n sc
511 return $ LLet n' (LForce (LV (Glob n))) sc'
513-- There are two transformations in this case:
514--
515-- 1. Newtype-case elimination:
516-- case {e0} of
517-- wrap({e1}) -> P({e1}) ==> P({e0})
518--
519-- This is important because newtyped constructors are compiled away entirely
520-- and we need to do that everywhere.
521--
522-- 2. Unused-case elimination (only valid for singleton branches):
523-- case {e0} of ==> P
524-- C(x,y) -> P[... x,y not used ...]
525--
526-- This is important for runtime because sometimes we case on irrelevant data:
527--
528-- In the example above, {e0} will most probably have been erased
529-- so this vain projection would make the resulting program segfault
530-- because the code generator still emits a PROJECT(...) G-machine instruction.
531--
532-- Hence, we check whether the variables are used at all
533-- and erase the casesplit if they are not.
534--
535irSC vs (Case up n [alt]) = do
536 replacement <- case alt of
537 ConCase cn a ns sc -> do
538 detag <- fgetState (opt_detaggable . ist_optimisation cn)
539 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
540 if detag && length used == 1
541 then return . Just $ substSC (ns !! head used) n sc
542 else return Nothing
543 _ -> return Nothing
545 case replacement of
546 Just sc -> irSC vs sc
547 _ -> do
548 alt' <- irAlt vs (LV (Glob n)) alt
549 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
550 [] -> subexpr alt' -- strip the unused top-most case
551 _ -> LCase up (LV (Glob n)) [alt']
552 where
553 namesBoundIn :: LAlt -> [Name]
554 namesBoundIn (LConCase cn i ns sc) = ns
555 namesBoundIn (LConstCase c sc) = []
556 namesBoundIn (LDefaultCase sc) = []
558 subexpr :: LAlt -> LExp
559 subexpr (LConCase _ _ _ e) = e
560 subexpr (LConstCase _ e) = e
561 subexpr (LDefaultCase e) = e
563-- FIXME: When we have a non-singleton case-tree of the form
564--
565-- case {e0} of
566-- C(x) => ...
567-- ... => ...
568--
569-- and C is detaggable (the only constructor of the family), we can be sure
570-- that the first branch will be always taken -- so we add special handling
571-- to remove the dead default branch.
572--
573-- If we don't do so and C is newtype-optimisable, we will miss this newtype
574-- transformation and the resulting code will probably segfault.
575--
576-- This work-around is not entirely optimal; the best approach would be
577-- to ensure that such case trees don't arise in the first place.
578--
579irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
580 detag <- fgetState (opt_detaggable . ist_optimisation cn)
581 if detag
582 then irSC vs (Case up n [ConCase cn a ns sc])
583 else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
585irSC vs sc@(Case up n alts) = do
586 -- check that neither alternative needs the newtype optimisation,
587 -- see comment above
588 goneWrong <- or <$> mapM isDetaggable alts
589 when goneWrong
590 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
592 -- everything okay
593 LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
594 where
595 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
596 isDetaggable _ = return False
598irSC vs ImpossibleCase = return LNothing
600irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
602-- this leaves out all unused arguments of the constructor
603irAlt vs _ (ConCase n t args sc) = do
604 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
605 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
606 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
607 where
608 methodVars = case n of
609 SN (InstanceCtorN className)
610 -> M.fromList [(v, VI
611 { viMethod = Just $ mkFieldName n i
612 }) | (v,i) <- zip args [0..]]
613 _
614 -> M.empty -- not an instance constructor
616irAlt vs _ (ConstCase x rhs)
617 | matchable x = LConstCase x <$> irSC vs rhs
618 | matchableTy x = LDefaultCase <$> irSC vs rhs
619 where
620 matchable (I _) = True
621 matchable (BI _) = True
622 matchable (Ch _) = True
623 matchable (Str _) = True
624 matchable (B8 _) = True
625 matchable (B16 _) = True
626 matchable (B32 _) = True
627 matchable (B64 _) = True
628 matchable _ = False
630 matchableTy (AType (ATInt ITNative)) = True
631 matchableTy (AType (ATInt ITBig)) = True
632 matchableTy (AType (ATInt ITChar)) = True
633 matchableTy StrType = True
635 matchableTy (AType (ATInt (ITFixed IT8))) = True
636 matchableTy (AType (ATInt (ITFixed IT16))) = True
637 matchableTy (AType (ATInt (ITFixed IT32))) = True
638 matchableTy (AType (ATInt (ITFixed IT64))) = True
640 matchableTy _ = False
642irAlt vs tm (SucCase n rhs) = do
643 rhs' <- irSC vs rhs
644 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
645 [tm,
646 LConst (BI 1)]) rhs')
648irAlt vs _ (ConstCase c rhs)
649 = ifail $ "Can't match on (" ++ show c ++ ")"
651irAlt vs _ (DefaultCase rhs)
652 = LDefaultCase <$> irSC vs rhs