Mattias Lundell avatar Mattias Lundell committed c2b7c87

gcinfo error corrected

Comments (0)

Files changed (3)

 
 module BitOps where
 
-
 instance intBITS32 :: IntLiteral BITS32 where
     fromInt = primIntToBITS32
 
 instance intBITS8 :: IntLiteral BITS8 where
     fromInt = primIntToBITS8
 
-    
 default intInt < intBITS8
 default intInt < intBITS16
 default intInt < intBITS32
 
 instance fromBITS8 :: ToInt BITS8 where
     toInt = primBITS8ToInt
-    
 
 typeclass BitsOp a where
-    band :: a -> a -> a        
-    bor  :: a -> a -> a        
-    bxor :: a -> a -> a        
-    binv :: a -> a             
-    bsll :: a -> Int -> a      
-    bsrl :: a -> Int -> a      
-    bsra :: a -> Int -> a      
-    bset :: a -> Int -> a      
-    bclr :: a -> Int -> a      
-    btst :: a -> Int -> Bool   
+    band :: a -> a -> a
+    bor  :: a -> a -> a
+    bxor :: a -> a -> a
+    binv :: a -> a
+    bsll :: a -> Int -> a
+    bsrl :: a -> Int -> a
+    bsra :: a -> Int -> a
+    bset :: a -> Int -> a
+    bclr :: a -> Int -> a
+    btst :: a -> Int -> Bool
 
 a .&. b  = band a b
 a .|. b  = bor  a b
-a .^. b  = bxor a b  
-a .<<. b = bsll a b   
-a .>>. b = bsrl a b 
-a .|=. b = bset a b   
-a .!=. b = bclr a b  
-a .?. b  = btst a b         
+a .^. b  = bxor a b
+a .<<. b = bsll a b
+a .>>. b = bsrl a b
+a .|=. b = bset a b
+a .!=. b = bclr a b
+a .?. b  = btst a b
 
 instance bitsOpBits32 :: BitsOp BITS32 where
     band   a b = primAND32 a b
     bsll   a i = primSHIFTL32 a i
     bsrl   a i = primSHIFTR32 a i
     bsra   a i = primSHIFTRA32 a i
-    bset   a i = primSET32 a i  
+    bset   a i = primSET32 a i
     bclr   a i = primCLR32 a i
     btst   a i = primTST32 a i
 
     bsll   a i = primSHIFTL16 a i
     bsrl   a i = primSHIFTR16 a i
     bsra   a i = primSHIFTRA16 a i
-    bset   a i = primSET16 a i  
+    bset   a i = primSET16 a i
     bclr   a i = primCLR16 a i
     btst   a i = primTST16 a i
 
     bsll   a i = primSHIFTL8 a i
     bsrl   a i = primSHIFTR8 a i
     bsra   a i = primSHIFTRA8 a i
-    bset   a i = primSET8 a i  
+    bset   a i = primSET8 a i
     bclr   a i = primCLR8 a i
     btst   a i = primTST8 a i
 
-                
 instance eqBits32 :: Eq BITS32 where
     a == b = primBITS32ToInt a == primBITS32ToInt b
     a /= b = primBITS32ToInt a /= primBITS32ToInt b
 showbits a n = if btst a n1 then '1' : str else '0' : str
   where n1  = n-1
         str = showbits a n1
-                    
-instance showBits32 :: Show BITS32 where 
+
+instance showBits32 :: Show BITS32 where
     show a = "0b" ++ showbits a 32
 
-instance showBits16 :: Show BITS16 where 
+instance showBits16 :: Show BITS16 where
     show a = "0b" ++ showbits a 16
 
-instance showBits8 :: Show BITS8 where 
+instance showBits8 :: Show BITS8 where
     show a = "0b" ++ showbits a 8
 
 
-hex a = if (a <= 9) then 
-            (chr (a + (ord '0'))) 
+hex a = if (a <= 9) then
+            (chr (a + (ord '0')))
         else
-            (chr ((a -10) + (ord 'A'))) 
+            (chr ((a -10) + (ord 'A')))
 
-    
-showh :: BITS32 -> Int -> String    
+showh :: BITS32 -> Int -> String
 showh a 0 = ""
-showh a n = ( hex (toInt((a `bsrl` (4 * n1)) `band` 0xF)) ) : str 
+showh a n = ( hex (toInt((a `bsrl` (4 * n1)) `band` 0xF)) ) : str
     where n1 = n - 1
           str = showh a n1
 

src/Kindle2LLVM.hs

 
 -- dsi contains structdefs Map Name Kindle.Decl
 kindle2llvm e2 e3 m@(Module name _ _ _ _) = do
-  let mod = runCodeGen (show name) (k2llvmModule e2 e3 m) 
+  let mod = runCodeGen (show name) (k2llvmModule e2 e3 m)
   -- tr $ show m
   return . render $ ppLLVMModule mod
 
 k2llvmModule (Core.Module _ _ _ es' _ _ [bs']) dsi (Module moduleName importNames es decls binds) = do
   -- add structs from imported files
   let te2 = Core.tsigsOf bs' ++ extsMap es'
-  tei <- Core2Kindle.c2kTEnv dsi te2 
+  tei <- Core2Kindle.c2kTEnv dsi te2
   let env1 = Prepare4C.addTEnv (primTEnv++tei++es) (Prepare4C.addDecls (primDecls++dsi) Prepare4C.env0)
       env  = Prepare4C.addTEnv (mapSnd typeOf binds) (Prepare4C.addDecls decls env1)
       ktypedEs = Prepare4C.pDecls env dsi
   genPrimitives
   -- struct declarations
   k2llvmStructDecls (decls ++ ktypedEs)
-  mapM_ (\(sname,_) -> 
-             addExternalGC (k2llvmName sname) (array 0 int)) ktypedEs 
+  mapM_ (\(sname,_) ->
+             addExternalGC (k2llvmName sname) (array 0 int)) ktypedEs
   k2llvmAddExternals (ktypedEf ++ es)
   k2llvmAddGlobalVars binds
   k2llvmHarvestFunTypes binds
   k2llvmTopBinds binds
   -- create _init_ module function
-  k2llvmInitModule moduleName importNames binds  
+  k2llvmInitModule moduleName importNames binds
   getModule
 
 -- | Add external functions and global variable bindings
 k2llvmAddExternals binds = mapM_ f binds
-    where 
+    where
       f (fname, FunT _ intyps outtyp) = do
         let outtyp' = k2llvmType outtyp
             intyps' = map k2llvmType intyps
         addFunType fname' (ptr (fun outtyp' intyps'))
         addExternalFun fname' outtyp' intyps'
       f (vname, ValT vtyp) = do
-        let vname' = k2llvmName vname 
+        let vname' = k2llvmName vname
             vtyp'  = k2llvmType vtyp
-            reg    = LLVMRegister (ptr vtyp') vname' 
+            reg    = LLVMRegister (ptr vtyp') vname'
                      (TagGlobal [External,Global] Nothing)
         addGlobalVar vname' reg
 
 -- | Generate type aliases for all struct declarations
 k2llvmStructDecls sdecls = mapM_ f sdecls
-    where 
-      f (sname, Struct _ vars _) = do 
+    where
+      f (sname, Struct _ vars _) = do
         let sname' = k2llvmName sname
             vars' = map (fixvars sname') vars
         addStruct sname' vars'
       fixvars sname (name, ValT typ) = (k2llvmName name, k2llvmType typ)
-      fixvars sname (name, FunT _ argtyps restyp) = 
-          (k2llvmName name, ptr (fun (k2llvmType restyp) 
+      fixvars sname (name, FunT _ argtyps restyp) =
+          (k2llvmName name, ptr (fun (k2llvmType restyp)
                                 (ptr (struct sname) : map k2llvmType argtyps)))
 
--- | Harvest all functions types from the current file, llvm needs type 
+-- | Harvest all functions types from the current file, llvm needs type
 --   information when generating function calls
 k2llvmHarvestFunTypes binds = mapM_ f binds
-    where f (fname, Fun _ atype atenv _) = 
-              addFunType (k2llvmName fname) 
-                         (ptr (fun (k2llvmType atype) 
+    where f (fname, Fun _ atype atenv _) =
+              addFunType (k2llvmName fname)
+                         (ptr (fun (k2llvmType atype)
                                    (map k2llvmType (snd (unzip atenv)))))
           f _ = return ()
 
         (offset,typ) <- getStructIndex typ_noptr name
         ftyp <- getFunType (k2llvmName fname)
         let freg = LLVMRegister ftyp (k2llvmName fname) (TagGlobal [] Nothing)
-        r1 <- getelementptr typ [intConst offset] r0 
-        if k2llvmName ntype == "CLOS" 
+        r1 <- getelementptr typ [intConst offset] r0
+        if k2llvmName ntype == "CLOS"
             then do
-              freg' <- bitcast (ptr (fun void [])) freg 
+              freg' <- bitcast (ptr (fun void [])) freg
               store freg' r1
             else store freg r1
       f (x,_) = internalError0 ("k2llvmStructBinds " ++ show x)
       f (vname, Val atype exp) = do
         let name = k2llvmName vname
             typ = k2llvmType atype
-        if isPtr typ 
+        if isPtr typ
           then
-              addGlobalVar name (LLVMRegister (ptr typ) name 
-                                 (TagGlobal [Common,Global] 
+              addGlobalVar name (LLVMRegister (ptr typ) name
+                                 (TagGlobal [Common,Global]
                                   (Just Null)))
           else
-              addGlobalVar name (LLVMRegister (ptr typ) name 
-                                 (TagGlobal [Common,Global] 
+              addGlobalVar name (LLVMRegister (ptr typ) name
+                                 (TagGlobal [Common,Global]
                                   (Just Zeroinitializer)))
       f _ = return ()
 
             -- Add unreachable (if function ends with a function call)
             unreachable
             addCurrFunction (k2llvmType funtyp) params
-          -- Create GCINFO array 
+          -- Create GCINFO array
           f b@(vname, Val _ (ECall (Prim GCINFO _) [] vs@(EVar v : _))) = do
             vals <- mapM (gcArray v) vs
             addLocalGC (array (length vals) int) (k2llvmName vname) vals
 
 -- | Add function parameters, all parameters are allocated in the toplevel
 --   basic block, this way llvm handles conversation from memory to register.
---   when using -mem2reg optimization pass. 
+--   when using -mem2reg optimization pass.
 addParams (var,typ) = do
   reg <- getNewNamedReg var typ
   case typ of
                addVar var r1
 
 -- | Generate llvm representation of a GC array
-gcArray v (EVar x) 
+gcArray v (EVar x)
     | x == v = do
          size <- getStructSize (struct (k2llvmName v))
          return $ intConst (LLVMKindle.words size)
     where f (vname, Val vtyp (ENew ntyp [] binds)) = do
             let typ = k2llvmType vtyp
                 name = k2llvmName vname
-            size <- getStructSize (dropPtrs typ)            
-            var <- lookupVar name           
+            size <- getStructSize (dropPtrs typ)
+            var <- lookupVar name
             r1 <- k2llvmNew var typ size
             addVar name r1
           f (vname, Val vtyp (ECast _ (ENew ntyp [] binds))) = do
                        store r1 r2
                        addVar name r2
           f _ = return ()
-          g (vname, Val vtyp (ENew ntyp [] binds)) = 
+          g (vname, Val vtyp (ENew ntyp [] binds)) =
               k2llvmStructBinds (EVar vname) ntyp binds
-          g (vname, Val vtyp (ECast _ (ENew ntyp [] binds))) = 
+          g (vname, Val vtyp (ECast _ (ENew ntyp [] binds))) =
               k2llvmStructBinds (ECast (tCon ntyp) (EVar vname)) ntyp binds
           g _ = return ()
 
                   LLVMRegister typ name tag <- getVar ("__GC__" ++ sname)
                   let r1 = LLVMRegister (ptr (dropPtrs typ)) name tag
                   r2 <- k2llvmExp (head exp)
-                  r3 <- ptrtoint int =<< getelementptr int [intConst 0] r1
-                  r4 <- inttoptr poly =<< add r3 r2
+                  r3 <- getelementptr int [r2] r1
                   r5 <- getstructelemptr "GCINFO" r0
-                  store r4 r5
+                  store r3 r5
 
 lit2const (LInt _ n) = intConst n
 lit2const (LChr _ c) = charConst c
 
 import POSIX
 
-a :: Array Int 
+a :: Array Int
 a = array [1..10000]
 
 foldlArray f u a = iter 0 u
 root world = do
     env = new posix world
     env.stdout.write (show (foldlArray (+) 0 a) ++ "\n")
-    env.exit 0
+    env.exit
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.