git.iko.soy/Idris-dev
on c6574b4 help sign in
Idris-dev/src/IRTS/Compiler.hs
647 lines 24 kB history raw
1{-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-}
3module IRTS.Compiler(compile, generate) where
5import IRTS.Lang
6import IRTS.Defunctionalise
7import IRTS.Simplified
8import IRTS.CodegenCommon
9import IRTS.CodegenC
10import IRTS.CodegenJava
11import IRTS.DumpBC
12import IRTS.CodegenJavaScript
13#ifdef IDRIS_LLVM
14import IRTS.CodegenLLVM
15#else
16import Util.LLVMStubs
17#endif
18import IRTS.Inliner
20import Idris.AbsSyntax
21import Idris.AbsSyntaxTree
22import Idris.ASTUtils
23import Idris.Erasure
24import Idris.Error
26import Debug.Trace
28import Idris.Core.TT
29import Idris.Core.Evaluate
30import Idris.Core.CaseTree
32import Control.Category
33import Prelude hiding (id, (.))
35import Control.Applicative
36import Control.Monad.State
37import Data.Maybe
38import Data.List
39import Data.Ord
40import Data.IntSet (IntSet)
41import qualified Data.IntSet as IS
42import qualified Data.Map as M
43import qualified Data.Set as S
44import System.Process
45import System.IO
46import System.Directory
47import System.Environment
48import System.FilePath ((</>), addTrailingPathSeparator)
50-- | Given a 'main' term to compiler, return the IRs which can be used to
51-- generate code.
52compile :: Codegen -> FilePath -> Term -> Idris CodegenInfo
53compile codegen f tm
54 = do checkMVs -- check for undefined metavariables
55 checkTotality -- refuse to compile if there are totality problems
56 reachableNames <- performUsageAnalysis
57 maindef <- irMain tm
58 iLOG $ "MAIN: " ++ show maindef
59 objs <- getObjectFiles codegen
60 libs <- getLibs codegen
61 flags <- getFlags codegen
62 hdrs <- getHdrs codegen
63 impdirs <- allImportDirs
64 defsIn <- mkDecls tm reachableNames
65 let defs = defsIn ++ [(sMN 0 "runMain", maindef)]
66 -- iputStrLn $ showSep "\n" (map show defs)
67 let (nexttag, tagged) = addTags 65536 (liftAll defs)
68 let ctxtIn = addAlist tagged emptyContext
69 iLOG "Defunctionalising"
70 let defuns_in = defunctionalise nexttag ctxtIn
71 logLvl 5 $ show defuns_in
72 iLOG "Inlining"
73 let defuns = inline defuns_in
74 logLvl 5 $ show defuns
75 iLOG "Resolving variables for CG"
76 -- iputStrLn $ showSep "\n" (map show (toAlist defuns))
77 let checked = checkDefs defuns (toAlist defuns)
78 outty <- outputTy
79 dumpCases <- getDumpCases
80 dumpDefun <- getDumpDefun
81 case dumpCases of
82 Nothing -> return ()
83 Just f -> runIO $ writeFile f (showCaseTrees defs)
84 case dumpDefun of
85 Nothing -> return ()
86 Just f -> runIO $ writeFile f (dumpDefuns defuns)
87 triple <- Idris.AbsSyntax.targetTriple
88 cpu <- Idris.AbsSyntax.targetCPU
89 optimise <- optLevel
90 iLOG "Building output"
92 case checked of
93 OK c -> do return $ CodegenInfo f outty triple cpu optimise
94 hdrs impdirs objs libs flags
95 NONE c (toAlist defuns)
96 tagged
97-- runIO $ case codegen of
98-- ViaC -> codegenC cginfo
99-- ViaJava -> codegenJava cginfo
100-- ViaJavaScript -> codegenJavaScript cginfo
101-- ViaNode -> codegenNode cginfo
102-- ViaLLVM -> codegenLLVM cginfo
103-- Bytecode -> dumpBC c f
104 Error e -> ierror e
105 where checkMVs = do i <- getIState
106 case map fst (idris_metavars i) \\ primDefs of
107 [] -> return ()
108 ms -> ifail $ "There are undefined metavariables: " ++ show ms
109 checkTotality = do i <- getIState
110 case idris_totcheckfail i of
111 [] -> return ()
112 ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg
113 inDir d h = do let f = d </> h
114 ex <- doesFileExist f
115 if ex then return f else return h
117generate :: Codegen -> CodegenInfo -> IO ()
118generate codegen ir = case codegen of
119 Via "c" -> codegenC ir
120 Via "java" -> codegenJava ir
121 Via "javascript" -> codegenJavaScript ir
122 Via "node" -> codegenNode ir
123 Via "llvm" -> codegenLLVM ir
124 Bytecode -> dumpBC (simpleDecls ir) (outputFile ir)
126irMain :: TT Name -> Idris LDecl
127irMain tm = do
128 i <- irTerm M.empty [] tm
129 return $ LFun [] (sMN 0 "runMain") [] (LForce i)
131mkDecls :: Term -> [Name] -> Idris [(Name, LDecl)]
132mkDecls t used
133 = do i <- getIState
134 let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
135 decls <- mapM build ds
136 return decls
138showCaseTrees :: [(Name, LDecl)] -> String
139showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)
140 where
141 showCT (n, LFun _ f args lexp)
142 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"
143 ++ show lexp
144 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
146 defnRank :: (Name, LDecl) -> String
147 defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n
148 defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n
150 nameRank :: Name -> String
151 nameRank (UN s) = "1" ++ show s
152 nameRank (MN i s) = "2" ++ show s ++ show i
153 nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n
154 nameRank (SN sn) = "4" ++ snRank sn
155 nameRank n = "5" ++ show n
157 snRank :: SpecialName -> String
158 snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i
159 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args
160 snRank (ParentN n s) = "3" ++ nameRank n ++ show s
161 snRank (MethodN n) = "4" ++ nameRank n
162 snRank (CaseN n) = "5" ++ nameRank n
163 snRank (ElimN n) = "6" ++ nameRank n
164 snRank (InstanceCtorN n) = "7" ++ nameRank n
166isCon (TyDecl _ _) = True
167isCon _ = False
169build :: (Name, Def) -> Idris (Name, LDecl)
170build (n, d)
171 = do i <- getIState
172 case lookup n (idris_scprims i) of
173 Just (ar, op) ->
174 let args = map (\x -> sMN x "op") [0..] in
175 return (n, (LFun [] n (take ar args)
176 (LOp op (map (LV . Glob) (take ar args)))))
177 _ -> do def <- mkLDecl n d
178 logLvl 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
179 return (n, def)
181declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x
182declArgs args inl n x = LFun (if inl then [Inline] else []) n args x
184mkLDecl n (Function tm _)
185 = declArgs [] True n <$> irTerm M.empty [] tm
187mkLDecl n (CaseOp ci _ _ _ pats cd)
188 = declArgs [] (case_inlinable ci) n <$> irTree args sc
189 where
190 (args, sc) = cases_runtime cd
192mkLDecl n (TyDecl (DCon tag arity) _) =
193 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)
195mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
196mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run
198data VarInfo = VI
199 { viMethod :: Maybe Name
200 }
201 deriving Show
203type Vars = M.Map Name VarInfo
205irTerm :: Vars -> [Name] -> Term -> Idris LExp
206irTerm vs env tm@(App f a) = case unApply tm of
207 (P _ (UN m) _, args)
208 | m == txt "mkForeignPrim"
209 -> doForeign vs env args
211 (P _ (UN u) _, [_, arg])
212 | u == txt "unsafePerformPrimIO"
213 -> irTerm vs env arg
215 -- TMP HACK - until we get inlining.
216 (P _ (UN r) _, [_, _, _, _, _, arg])
217 | r == txt "replace"
218 -> irTerm vs env arg
220 -- Laziness, the old way
221 (P _ (UN l) _, [_, arg])
222 | l == txt "lazy"
223 -> error "lazy has crept in somehow"
225 (P _ (UN l) _, [_, arg])
226 | l == txt "force"
227 -> LForce <$> irTerm vs env arg
229 -- Laziness, the new way
230 (P _ (UN l) _, [_, _, arg])
231 | l == txt "Delay"
232 -> LLazyExp <$> irTerm vs env arg
234 (P _ (UN l) _, [_, _, arg])
235 | l == txt "Force"
236 -> LForce <$> irTerm vs env arg
238 (P _ (UN a) _, [_, _, _, arg])
239 | a == txt "assert_smaller"
240 -> irTerm vs env arg
242 (P _ (UN a) _, [_, arg])
243 | a == txt "assert_total"
244 -> irTerm vs env arg
246 (P _ (UN p) _, [_, arg])
247 | p == txt "par"
248 -> do arg' <- irTerm vs env arg
249 return $ LOp LPar [LLazyExp arg']
251 (P _ (UN pf) _, [arg])
252 | pf == txt "prim_fork"
253 -> do arg' <- irTerm vs env arg
254 return $ LOp LFork [LLazyExp arg']
256 (P _ (UN m) _, [_,size,t])
257 | m == txt "malloc"
258 -> irTerm vs env t
260 (P _ (UN tm) _, [_,t])
261 | tm == txt "trace_malloc"
262 -> irTerm vs env t -- TODO
264 -- This case is here until we get more general inlining. It's just
265 -- a really common case, and the laziness hurts...
266 (P _ (NS (UN be) [b,p]) _, [_,x,(App (App (App (P _ (UN d) _) _) _) t),
267 (App (App (App (P _ (UN d') _) _) _) e)])
268 | be == txt "boolElim"
269 , d == txt "Delay"
270 , d' == txt "Delay"
271 -> do
272 x' <- irTerm vs env x
273 t' <- irTerm vs env t
274 e' <- irTerm vs env e
275 return (LCase x' [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
276 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
277 ])
279 -- data constructor
280 (P (DCon t arity) n _, args) -> do
281 detag <- fgetState (opt_detaggable . ist_optimisation n)
282 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
284 let isNewtype = length used == 1 && detag
285 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
287 -- The following code removes fields from data constructors
288 -- and performs the newtype optimisation.
289 --
290 -- The general rule here is:
291 -- Everything we get as input is not touched by erasure,
292 -- so it conforms to the official arities and types
293 -- and we can reason about it like it's plain TT.
294 --
295 -- It's only the data that leaves this point that's erased
296 -- and possibly no longer typed as the original TT version.
297 --
298 -- Especially, underapplied constructors must yield functions
299 -- even if all the remaining arguments are erased
300 -- (the resulting function *will* be applied, to NULLs).
301 --
302 -- This will probably need rethinking when we get erasure from functions.
304 -- "padLams" will wrap our term in LLam-bdas and give us
305 -- the "list of future unerased args" coming from these lambdas.
306 --
307 -- We can do whatever we like with the list of unerased args,
308 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
309 let padLams = padLambdas used (length args) arity
311 case compare (length args) arity of
313 -- overapplied
314 GT -> ifail ("overapplied data constructor: " ++ show tm)
316 -- exactly saturated
317 EQ | isNewtype
318 -> irTerm vs env (head argsPruned)
320 | otherwise -- not newtype, plain data ctor
321 -> buildApp (LV $ Glob n) argsPruned
323 -- not saturated, underapplied
324 LT | isNewtype -- newtype
325 , length argsPruned == 1 -- and we already have the value
326 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
327 <$> irTerm vs env (head argsPruned)
329 | isNewtype -- newtype but the value is not among args yet
330 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
332 -- not a newtype, just apply to a constructor
333 | otherwise
334 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
336 -- type constructor
337 (P (TCon t a) n _, args) -> return LNothing
339 -- a name applied to arguments
340 (P _ n _, args) -> do
341 ist <- getIState
342 case lookup n (idris_scprims ist) of
343 -- if it's a primitive that is already saturated,
344 -- compile to the corresponding op here already to save work
345 Just (arity, op) | length args == arity
346 -> LOp op <$> mapM (irTerm vs env) args
348 -- otherwise, just apply the name
349 _ -> applyName n ist args
351 -- turn de bruijn vars into regular named references and try again
352 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
354 (f, args)
355 -> LApp False
356 <$> irTerm vs env f
357 <*> mapM (irTerm vs env) args
359 where
360 buildApp :: LExp -> [Term] -> Idris LExp
361 buildApp e [] = return e
362 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
364 applyToNames :: LExp -> [Name] -> LExp
365 applyToNames tm [] = tm
366 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
368 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
369 padLambdas used startIdx endSIdx mkTerm
370 = LLam allNames $ mkTerm nonerasedNames
371 where
372 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
373 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
375 applyName :: Name -> IState -> [Term] -> Idris LExp
376 applyName n ist args =
377 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
378 where
379 erase (i, x)
380 | i >= arity || i `elem` used = x
381 | otherwise = Erased
383 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
384 Just (CaseOp ci ty tys def tot cdefs) -> length tys
385 Just (TyDecl (DCon tag ar) _) -> ar
386 Just (TyDecl Ref ty) -> length $ getArgTys ty
387 Just (Operator ty ar op) -> ar
388 Just def -> error $ "unknown arity: " ++ show (n, def)
389 Nothing -> 0 -- no definition, probably local name => can't erase anything
391 -- name for purposes of usage info lookup
392 uName
393 | Just n' <- viMethod =<< M.lookup n vs = n'
394 | otherwise = n
396 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
397 fst4 (x,_,_,_) = x
399irTerm vs env (P _ n _) = return $ LV (Glob n)
400irTerm vs env (V i)
401 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
402 | otherwise = ifail $ "bad de bruijn index: " ++ show i
404irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
405 where
406 n' = uniqueName n env
408irTerm vs env (Bind n (Let _ v) sc)
409 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
411irTerm vs env (Bind _ _ _) = return $ LNothing
413irTerm vs env (Proj t (-1)) = do
414 t' <- irTerm vs env t
415 return $ LOp (LMinus (ATInt ITBig))
416 [t', LConst (BI 1)]
418irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
419irTerm vs env (Constant c) = return $ LConst c
420irTerm vs env (TType _) = return $ LNothing
421irTerm vs env Erased = return $ LNothing
422irTerm vs env Impossible = return $ LNothing
424doForeign :: Vars -> [Name] -> [TT Name] -> Idris LExp
425doForeign vs env (_ : fgn : args)
426 | (_, (Constant (Str fgnName) : fgnArgTys : ret : [])) <- unApply fgn
427 = case getFTypes fgnArgTys of
428 Nothing -> ifail $ "Foreign type specification is not a constant list: " ++ show (fgn:args)
429 Just tys -> do
430 args' <- mapM (irTerm vs env) (init args)
431 return $ LForeign LANG_C (mkIty' ret) fgnName (zip tys args')
433 | otherwise = ifail "Badly formed foreign function call"
434 where
435 getFTypes :: TT Name -> Maybe [FType]
436 getFTypes tm = case unApply tm of
437 -- nil : {a : Type} -> List a
438 (nil, [_]) -> Just []
439 -- cons : {a : Type} -> a -> List a -> List a
440 (cons, [_, ty, xs]) -> (mkIty' ty :) <$> getFTypes xs
441 _ -> Nothing
443 mkIty' (P _ (UN ty) _) = mkIty (str ty)
444 mkIty' (App (P _ (UN fi) _) (P _ (UN intTy) _))
445 | fi == txt "FIntT"
446 = mkIntIty (str intTy)
448 mkIty' (App (App (P _ (UN ff) _) _) (App (P _ (UN fa) _) (App (P _ (UN io) _) _)))
449 | ff == txt "FFunction"
450 , fa == txt "FAny"
451 , io == txt "IO"
452 = FFunctionIO
454 mkIty' (App (App (P _ (UN ff) _) _) _)
455 | ff == txt "FFunction"
456 = FFunction
458 mkIty' _ = FAny
460 -- would be better if these FInt types were evaluated at compile time
461 -- TODO: add %eval directive for such things
463 mkIty "FFloat" = FArith ATFloat
464 mkIty "FInt" = mkIntIty "ITNative"
465 mkIty "FChar" = mkIntIty "ITChar"
466 mkIty "FByte" = mkIntIty "IT8"
467 mkIty "FShort" = mkIntIty "IT16"
468 mkIty "FLong" = mkIntIty "IT64"
469 mkIty "FBits8" = mkIntIty "IT8"
470 mkIty "FBits16" = mkIntIty "IT16"
471 mkIty "FBits32" = mkIntIty "IT32"
472 mkIty "FBits64" = mkIntIty "IT64"
473 mkIty "FString" = FString
474 mkIty "FPtr" = FPtr
475 mkIty "FManagedPtr" = FManagedPtr
476 mkIty "FUnit" = FUnit
477 mkIty "FFunction" = FFunction
478 mkIty "FFunctionIO" = FFunctionIO
479 mkIty "FBits8x16" = FArith (ATInt (ITVec IT8 16))
480 mkIty "FBits16x8" = FArith (ATInt (ITVec IT16 8))
481 mkIty "FBits32x4" = FArith (ATInt (ITVec IT32 4))
482 mkIty "FBits64x2" = FArith (ATInt (ITVec IT64 2))
483 mkIty x = error $ "Unknown type " ++ x
485 mkIntIty "ITNative" = FArith (ATInt ITNative)
486 mkIntIty "ITChar" = FArith (ATInt ITChar)
487 mkIntIty "IT8" = FArith (ATInt (ITFixed IT8))
488 mkIntIty "IT16" = FArith (ATInt (ITFixed IT16))
489 mkIntIty "IT32" = FArith (ATInt (ITFixed IT32))
490 mkIntIty "IT64" = FArith (ATInt (ITFixed IT64))
492irTree :: [Name] -> SC -> Idris LExp
493irTree args tree = do
494 logLvl 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
495 LLam args <$> irSC M.empty tree
497irSC :: Vars -> SC -> Idris LExp
498irSC vs (STerm t) = irTerm vs [] t
499irSC vs (UnmatchedCase str) = return $ LError str
501irSC vs (ProjCase tm alts) = do
502 tm' <- irTerm vs [] tm
503 alts' <- mapM (irAlt vs tm') alts
504 return $ LCase tm' alts'
506-- Transform matching on Delay to applications of Force.
507irSC vs (Case n [ConCase (UN delay) i [_, _, n'] sc])
508 | delay == txt "Delay"
509 = do sc' <- irSC vs $ mkForce n' n sc
510 return $ LLet n' (LForce (LV (Glob n))) sc'
512-- There are two transformations in this case:
513--
514-- 1. Newtype-case elimination:
515-- case {e0} of
516-- wrap({e1}) -> P({e1}) ==> P({e0})
517--
518-- This is important because newtyped constructors are compiled away entirely
519-- and we need to do that everywhere.
520--
521-- 2. Unused-case elimination (only valid for singleton branches):
522-- case {e0} of ==> P
523-- C(x,y) -> P[... x,y not used ...]
524--
525-- This is important for runtime because sometimes we case on irrelevant data:
526--
527-- In the example above, {e0} will most probably have been erased
528-- so this vain projection would make the resulting program segfault
529-- because the code generator still emits a PROJECT(...) G-machine instruction.
530--
531-- Hence, we check whether the variables are used at all
532-- and erase the casesplit if they are not.
533--
534irSC vs (Case n [alt]) = do
535 replacement <- case alt of
536 ConCase cn a ns sc -> do
537 detag <- fgetState (opt_detaggable . ist_optimisation cn)
538 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
539 if detag && length used == 1
540 then return . Just $ substSC (ns !! head used) n sc
541 else return Nothing
542 _ -> return Nothing
544 case replacement of
545 Just sc -> irSC vs sc
546 _ -> do
547 alt' <- irAlt vs (LV (Glob n)) alt
548 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
549 [] -> subexpr alt' -- strip the unused top-most case
550 _ -> LCase (LV (Glob n)) [alt']
551 where
552 namesBoundIn :: LAlt -> [Name]
553 namesBoundIn (LConCase cn i ns sc) = ns
554 namesBoundIn (LConstCase c sc) = []
555 namesBoundIn (LDefaultCase sc) = []
557 subexpr :: LAlt -> LExp
558 subexpr (LConCase _ _ _ e) = e
559 subexpr (LConstCase _ e) = e
560 subexpr (LDefaultCase e) = e
562-- FIXME: When we have a non-singleton case-tree of the form
563--
564-- case {e0} of
565-- C(x) => ...
566-- ... => ...
567--
568-- and C is detaggable (the only constructor of the family), we can be sure
569-- that the first branch will be always taken -- so we add special handling
570-- to remove the dead default branch.
571--
572-- If we don't do so and C is newtype-optimisable, we will miss this newtype
573-- transformation and the resulting code will probably segfault.
574--
575-- This work-around is not entirely optimal; the best approach would be
576-- to ensure that such case trees don't arise in the first place.
577--
578irSC vs (Case n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
579 detag <- fgetState (opt_detaggable . ist_optimisation cn)
580 if detag
581 then irSC vs (Case n [ConCase cn a ns sc])
582 else LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
584irSC vs sc@(Case n alts) = do
585 -- check that neither alternative needs the newtype optimisation,
586 -- see comment above
587 goneWrong <- or <$> mapM isDetaggable alts
588 when goneWrong
589 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
591 -- everything okay
592 LCase (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
593 where
594 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
595 isDetaggable _ = return False
597irSC vs ImpossibleCase = return LNothing
599irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
601-- this leaves out all unused arguments of the constructor
602irAlt vs _ (ConCase n t args sc) = do
603 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
604 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
605 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
606 where
607 methodVars = case n of
608 SN (InstanceCtorN className)
609 -> M.fromList [(v, VI
610 { viMethod = Just $ mkFieldName n i
611 }) | (v,i) <- zip args [0..]]
612 _
613 -> M.empty -- not an instance constructor
615irAlt vs _ (ConstCase x rhs)
616 | matchable x = LConstCase x <$> irSC vs rhs
617 | matchableTy x = LDefaultCase <$> irSC vs rhs
618 where
619 matchable (I _) = True
620 matchable (BI _) = True
621 matchable (Ch _) = True
622 matchable (Str _) = True
623 matchable _ = False
625 matchableTy (AType (ATInt ITNative)) = True
626 matchableTy (AType (ATInt ITBig)) = True
627 matchableTy (AType (ATInt ITChar)) = True
628 matchableTy StrType = True
630 matchableTy (AType (ATInt (ITFixed IT8))) = True
631 matchableTy (AType (ATInt (ITFixed IT16))) = True
632 matchableTy (AType (ATInt (ITFixed IT32))) = True
633 matchableTy (AType (ATInt (ITFixed IT64))) = True
635 matchableTy _ = False
637irAlt vs tm (SucCase n rhs) = do
638 rhs' <- irSC vs rhs
639 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
640 [tm,
641 LConst (BI 1)]) rhs')
643irAlt vs _ (ConstCase c rhs)
644 = ifail $ "Can't match on (" ++ show c ++ ")"
646irAlt vs _ (DefaultCase rhs)
647 = LDefaultCase <$> irSC vs rhs