git.iko.soy/Idris-dev
on e105606 help sign in
Idris-dev/src/IRTS/Compiler.hs
642 lines 23 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 -- Laziness, the old way
250 (P _ (UN l) _, [_, arg])
251 | l == txt "lazy"
252 -> error "lazy has crept in somehow"
254 (P _ (UN l) _, [_, arg])
255 | l == txt "force"
256 -> LForce <$> irTerm vs env arg
258 -- Laziness, the new way
259 (P _ (UN l) _, [_, _, arg])
260 | l == txt "Delay"
261 -> LLazyExp <$> irTerm vs env arg
263 (P _ (UN l) _, [_, _, arg])
264 | l == txt "Force"
265 -> LForce <$> irTerm vs env arg
267 (P _ (UN a) _, [_, _, _, arg])
268 | a == txt "assert_smaller"
269 -> irTerm vs env arg
271 (P _ (UN a) _, [_, arg])
272 | a == txt "assert_total"
273 -> irTerm vs env arg
275 (P _ (UN p) _, [_, arg])
276 | p == txt "par"
277 -> do arg' <- irTerm vs env arg
278 return $ LOp LPar [LLazyExp arg']
280 (P _ (UN pf) _, [arg])
281 | pf == txt "prim_fork"
282 -> do arg' <- irTerm vs env arg
283 return $ LOp LFork [LLazyExp arg']
285 (P _ (UN m) _, [_,size,t])
286 | m == txt "malloc"
287 -> irTerm vs env t
289 (P _ (UN tm) _, [_,t])
290 | tm == txt "trace_malloc"
291 -> irTerm vs env t -- TODO
293 -- This case is here until we get more general inlining. It's just
294 -- a really common case, and the laziness hurts...
295 (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),
296 (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])
297 | be == txt "ifThenElse"
298 , d == txt "Delay"
299 , d' == txt "Delay"
300 , b == txt "Bool"
301 , p == txt "Prelude"
302 -> do
303 x' <- irTerm vs env x
304 t' <- irTerm vs env t
305 e' <- irTerm vs env e
306 return (LCase Shared x'
307 [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
308 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
309 ])
311 -- data constructor
312 (P (DCon t arity _) n _, args) -> do
313 detag <- fgetState (opt_detaggable . ist_optimisation n)
314 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
316 let isNewtype = length used == 1 && detag
317 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
319 -- The following code removes fields from data constructors
320 -- and performs the newtype optimisation.
321 --
322 -- The general rule here is:
323 -- Everything we get as input is not touched by erasure,
324 -- so it conforms to the official arities and types
325 -- and we can reason about it like it's plain TT.
326 --
327 -- It's only the data that leaves this point that's erased
328 -- and possibly no longer typed as the original TT version.
329 --
330 -- Especially, underapplied constructors must yield functions
331 -- even if all the remaining arguments are erased
332 -- (the resulting function *will* be applied, to NULLs).
333 --
334 -- This will probably need rethinking when we get erasure from functions.
336 -- "padLams" will wrap our term in LLam-bdas and give us
337 -- the "list of future unerased args" coming from these lambdas.
338 --
339 -- We can do whatever we like with the list of unerased args,
340 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
341 let padLams = padLambdas used (length args) arity
343 case compare (length args) arity of
345 -- overapplied
346 GT -> ifail ("overapplied data constructor: " ++ show tm)
348 -- exactly saturated
349 EQ | isNewtype
350 -> irTerm vs env (head argsPruned)
352 | otherwise -- not newtype, plain data ctor
353 -> buildApp (LV $ Glob n) argsPruned
355 -- not saturated, underapplied
356 LT | isNewtype -- newtype
357 , length argsPruned == 1 -- and we already have the value
358 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
359 <$> irTerm vs env (head argsPruned)
361 | isNewtype -- newtype but the value is not among args yet
362 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
364 -- not a newtype, just apply to a constructor
365 | otherwise
366 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
368 -- type constructor
369 (P (TCon t a) n _, args) -> return LNothing
371 -- an external name applied to arguments
372 (P _ n _, args) | S.member (n, length args) (idris_externs ist) -> do
373 LOp (LExternal n) <$> mapM (irTerm vs env) args
375 -- a name applied to arguments
376 (P _ n _, args) -> do
377 case lookup n (idris_scprims ist) of
378 -- if it's a primitive that is already saturated,
379 -- compile to the corresponding op here already to save work
380 Just (arity, op) | length args == arity
381 -> LOp op <$> mapM (irTerm vs env) args
383 -- otherwise, just apply the name
384 _ -> applyName n ist args
386 -- turn de bruijn vars into regular named references and try again
387 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
389 (f, args)
390 -> LApp False
391 <$> irTerm vs env f
392 <*> mapM (irTerm vs env) args
394 where
395 buildApp :: LExp -> [Term] -> Idris LExp
396 buildApp e [] = return e
397 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
399 applyToNames :: LExp -> [Name] -> LExp
400 applyToNames tm [] = tm
401 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
403 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
404 padLambdas used startIdx endSIdx mkTerm
405 = LLam allNames $ mkTerm nonerasedNames
406 where
407 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
408 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
410 applyName :: Name -> IState -> [Term] -> Idris LExp
411 applyName n ist args =
412 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
413 where
414 erase (i, x)
415 | i >= arity || i `elem` used = x
416 | otherwise = Erased
418 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
419 Just (CaseOp ci ty tys def tot cdefs) -> length tys
420 Just (TyDecl (DCon tag ar _) _) -> ar
421 Just (TyDecl Ref ty) -> length $ getArgTys ty
422 Just (Operator ty ar op) -> ar
423 Just def -> error $ "unknown arity: " ++ show (n, def)
424 Nothing -> 0 -- no definition, probably local name => can't erase anything
426 -- name for purposes of usage info lookup
427 uName
428 | Just n' <- viMethod =<< M.lookup n vs = n'
429 | otherwise = n
431 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
432 fst4 (x,_,_,_) = x
434irTerm vs env (P _ n _) = return $ LV (Glob n)
435irTerm vs env (V i)
436 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
437 | otherwise = ifail $ "bad de bruijn index: " ++ show i
439irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
440 where
441 n' = uniqueName n env
443irTerm vs env (Bind n (Let _ v) sc)
444 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
446irTerm vs env (Bind _ _ _) = return $ LNothing
448irTerm vs env (Proj t (-1)) = do
449 t' <- irTerm vs env t
450 return $ LOp (LMinus (ATInt ITBig))
451 [t', LConst (BI 1)]
453irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
454irTerm vs env (Constant TheWorld) = return $ LNothing
455irTerm vs env (Constant c) = return $ LConst c
456irTerm vs env (TType _) = return $ LNothing
457irTerm vs env Erased = return $ LNothing
458irTerm vs env Impossible = return $ LNothing
460doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
461doForeign vs env (ret : fname : world : args)
462 = do args' <- mapM splitArg args
463 let fname' = toFDesc fname
464 let ret' = toFDesc ret
465 return $ LForeign ret' fname' args'
466 where
467 splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
468 = do let l' = toFDesc l
469 r' <- irTerm vs env r
470 return (l', r')
471 splitArg _ = ifail $ "Badly formed foreign function call"
473 toFDesc (Constant (Str str)) = FStr str
474 toFDesc tm
475 | (P _ n _, []) <- unApply tm = FCon (deNS n)
476 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)
477 toFDesc _ = FUnknown
479 deNS (NS n _) = n
480 deNS n = n
481doForeign vs env xs = ifail "Badly formed foreign function call"
483irTree :: [Name] -> SC -> Idris LExp
484irTree args tree = do
485 logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
486 LLam args <$> irSC M.empty tree
488irSC :: Vars -> SC -> Idris LExp
489irSC vs (STerm t) = irTerm vs [] t
490irSC vs (UnmatchedCase str) = return $ LError str
492irSC vs (ProjCase tm alts) = do
493 tm' <- irTerm vs [] tm
494 alts' <- mapM (irAlt vs tm') alts
495 return $ LCase Shared tm' alts'
497-- Transform matching on Delay to applications of Force.
498irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])
499 | delay == txt "Delay"
500 = do sc' <- irSC vs $ mkForce n' n sc
501 return $ LLet n' (LForce (LV (Glob n))) sc'
503-- There are two transformations in this case:
504--
505-- 1. Newtype-case elimination:
506-- case {e0} of
507-- wrap({e1}) -> P({e1}) ==> P({e0})
508--
509-- This is important because newtyped constructors are compiled away entirely
510-- and we need to do that everywhere.
511--
512-- 2. Unused-case elimination (only valid for singleton branches):
513-- case {e0} of ==> P
514-- C(x,y) -> P[... x,y not used ...]
515--
516-- This is important for runtime because sometimes we case on irrelevant data:
517--
518-- In the example above, {e0} will most probably have been erased
519-- so this vain projection would make the resulting program segfault
520-- because the code generator still emits a PROJECT(...) G-machine instruction.
521--
522-- Hence, we check whether the variables are used at all
523-- and erase the casesplit if they are not.
524--
525irSC vs (Case up n [alt]) = do
526 replacement <- case alt of
527 ConCase cn a ns sc -> do
528 detag <- fgetState (opt_detaggable . ist_optimisation cn)
529 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
530 if detag && length used == 1
531 then return . Just $ substSC (ns !! head used) n sc
532 else return Nothing
533 _ -> return Nothing
535 case replacement of
536 Just sc -> irSC vs sc
537 _ -> do
538 alt' <- irAlt vs (LV (Glob n)) alt
539 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
540 [] -> subexpr alt' -- strip the unused top-most case
541 _ -> LCase up (LV (Glob n)) [alt']
542 where
543 namesBoundIn :: LAlt -> [Name]
544 namesBoundIn (LConCase cn i ns sc) = ns
545 namesBoundIn (LConstCase c sc) = []
546 namesBoundIn (LDefaultCase sc) = []
548 subexpr :: LAlt -> LExp
549 subexpr (LConCase _ _ _ e) = e
550 subexpr (LConstCase _ e) = e
551 subexpr (LDefaultCase e) = e
553-- FIXME: When we have a non-singleton case-tree of the form
554--
555-- case {e0} of
556-- C(x) => ...
557-- ... => ...
558--
559-- and C is detaggable (the only constructor of the family), we can be sure
560-- that the first branch will be always taken -- so we add special handling
561-- to remove the dead default branch.
562--
563-- If we don't do so and C is newtype-optimisable, we will miss this newtype
564-- transformation and the resulting code will probably segfault.
565--
566-- This work-around is not entirely optimal; the best approach would be
567-- to ensure that such case trees don't arise in the first place.
568--
569irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
570 detag <- fgetState (opt_detaggable . ist_optimisation cn)
571 if detag
572 then irSC vs (Case up n [ConCase cn a ns sc])
573 else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
575irSC vs sc@(Case up n alts) = do
576 -- check that neither alternative needs the newtype optimisation,
577 -- see comment above
578 goneWrong <- or <$> mapM isDetaggable alts
579 when goneWrong
580 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
582 -- everything okay
583 LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
584 where
585 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
586 isDetaggable _ = return False
588irSC vs ImpossibleCase = return LNothing
590irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
592-- this leaves out all unused arguments of the constructor
593irAlt vs _ (ConCase n t args sc) = do
594 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
595 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
596 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
597 where
598 methodVars = case n of
599 SN (InstanceCtorN className)
600 -> M.fromList [(v, VI
601 { viMethod = Just $ mkFieldName n i
602 }) | (v,i) <- zip args [0..]]
603 _
604 -> M.empty -- not an instance constructor
606irAlt vs _ (ConstCase x rhs)
607 | matchable x = LConstCase x <$> irSC vs rhs
608 | matchableTy x = LDefaultCase <$> irSC vs rhs
609 where
610 matchable (I _) = True
611 matchable (BI _) = True
612 matchable (Ch _) = True
613 matchable (Str _) = True
614 matchable (B8 _) = True
615 matchable (B16 _) = True
616 matchable (B32 _) = True
617 matchable (B64 _) = True
618 matchable _ = False
620 matchableTy (AType (ATInt ITNative)) = True
621 matchableTy (AType (ATInt ITBig)) = True
622 matchableTy (AType (ATInt ITChar)) = True
623 matchableTy StrType = True
625 matchableTy (AType (ATInt (ITFixed IT8))) = True
626 matchableTy (AType (ATInt (ITFixed IT16))) = True
627 matchableTy (AType (ATInt (ITFixed IT32))) = True
628 matchableTy (AType (ATInt (ITFixed IT64))) = True
630 matchableTy _ = False
632irAlt vs tm (SucCase n rhs) = do
633 rhs' <- irSC vs rhs
634 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
635 [tm,
636 LConst (BI 1)]) rhs')
638irAlt vs _ (ConstCase c rhs)
639 = ifail $ "Can't match on (" ++ show c ++ ")"
641irAlt vs _ (DefaultCase rhs)
642 = LDefaultCase <$> irSC vs rhs